Question

我有桌子（见下文），我的宏根据设置条件发送带有附件的电子邮件。

我想要的是，如果编号与表2_3803063（两行）中的示例相同，则宏将向用户3803063发送一封电子邮件，其中包含两张位于第一列的发票。

我现在拥有的是如果条件为1则发送的代码，每个用户一张发票

For Each cell In wsA.Range("A3:A" & lastRow).SpecialCells(xlCellTypeVisible)

    '~~> codition 1
        If cell.Offset(0, 5) = "1" Then

'~~> vlookups for email ged email based on custmer number
        i = cell.Value

        cnum = Application.WorksheetFunction.VLookup(i, tablear, 8, False) '~~> get customer number

        processor = Application.WorksheetFunction.VLookup(CLng(cnum), r, 4, False) '~~> get customer mail


        If processor Like "?*@?*.?*" Then
            Set OutMail = OutApp.CreateItem(0)

            strbody = "Dear Customer," & vbNewLine & vbNewLine & "Please find attached credit note/add bill for your attention." _
            & vbNewLine & vbNewLine & "Billing Department" _
            & vbNewLine & vbNewLine & "*Please do not reply on this email. If you require further information please contact us on *"


            With OutMail
                .To = MeMail 'processor
                .Subject = "Emailing Document " & cell.Value
                .body = strbody

          '~~> send file from back up folder if backup exists
            If cell.Offset(0, 4) <> "Backup found" Then
                .Attachments.Add topath & cell.Value & ".pdf"
            Else
                .Attachments.Add backup & cell.Value & ".pdf"
            End If

'                For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
'                    If Trim(FileCell) <> "" Then
'                        If Dir(FileCell.Value) <> "" Then
'                            .Attachments.Add FileCell.Value
'                        End If
'                    End If
'                Next FileCell

                .send  'Or use .Display
            End With

            Set OutMail = Nothing
        End If
      End If
    Next cell

更新：我昨天找到了一个代码并修改了它，但我对此并不完全满意。电子邮件是从不同的工作表中获取的，或者是基于发票编号的Application.WorksheetFunction.VLookup，而不是返回电子邮件。下面的测试还没有实现vlookup。

    Sub Test1()
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    Dim r As Long

    Set wbI = ThisWorkbook
    Set wsA = wbI.Sheets(Invoices)
    Set tbl = wsA.ListObjects("tblInput")

    Set rng = ActiveSheet.UsedRange
    topath = "U:\path\IE Macro\PDF\" & Year(Date) & "\"
    r = 3

    Set OutApp = CreateObject("Outlook.Application")
lastRow = shtInput.Cells(Rows.count, 1).End(xlUp).Row
For Each cell In wsA.Range("A3:A" & lastRow).SpecialCells(xlCellTypeVisible)

          If Left(cell.Offset(0, 5), 1) = "2" Then
               ' tbl.Range.AutoFilter Field:=6, Criteria1:=cell.Offset(0, 5).Value

                With rng
                    '~~> Some Filter. Change as applicable
                    tbl.Range.AutoFilter Field:=6, Criteria1:="2*"

                    '~~> Get the filtered range
                    Set rng = .SpecialCells(xlCellTypeVisible)
                End With


    Do While r <= rng.Rows.count
        Set OutMail = OutApp.CreateItem(0)

        With OutMail
            .To = meMail '~~> constant with string
            .Subject = rng.Cells(r, 3).Value & " Report"
            .HTMLBody = ""
           .Attachments.Add (topath & cell.Value & ".pdf")
            'See if the next row is for the same client.  If so, process that
            'row as well.  And then keep doing it until no more rows match
            Do While (rng.Cells(r, 6).Value = rng.Cells(r + 1, 6) And Left(rng.Cells(r, 6), 1) = 2)
                r = r + 1
                '.HTMLBody = .HTMLBody & "</br>" & "This is how much was spent on the " & rng.Cells(r, 3).Value & " account:" & rng.Cells(r, 4).Value
                .Attachments.Add (topath & rng.Cells(r, 1).Value & ".pdf")
            Loop
            .send

        End With
        Set OutMail = Nothing
        r = r + 1
    Loop

        tbl.Range.AutoFilter Field:=6
    End If
Next cell

    Set OutApp = Nothing

End Sub

vba电子邮件文件到列表中的单个接收者

0 个答案: