从单个数据工作表向多个供应商发送电子邮件

Question

到目前为止，我已经创建了一个可以从一行数据创建电子邮件的宏，数据会进入电子邮件正文，但这会同时向同一个供应商发送多封电子邮件。

我想将数据合并并作为文件附加到电子邮件中。 我的问题是有多个供应商我想通过电子邮件发送同一个数据文件，我似乎无法在任何其他论坛上找到类似的东西，可以按供应商名称选择数据并合并到1个附件上

Sub OustandingDocs_Checker()

'Turn off screen updating, alerts and make the sheet calculation automatic
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.Calculation = xlAutomatic

'Set the Dimensions (Data Types) for the variables

    Dim Rng, Rng2, Rng3 As Range
    Dim cell As Range
    Dim Lrow As Long
    Dim FieldNum As Integer
    Dim Email, Email2 As String
    Dim OutApp As Object
    Dim OutMail As Object
    Dim rFound As Long
    Dim FindString, FindString2, FindString3 As String
    Dim SO, Supplier, TOrder, FinalDest, Mode, CRD, Inv, CreatedBy As String

'Set reference to the worksheet for future call-backs

    Set ws1 = Sheets("Data")


'Set Rng as the dynamic table size

    With ws1
        Set Rng = ws1.Range("A1:R" & Rows.Count)
        FieldNum = 1
    Lrow = .Cells(Rows.Count, "A").End(xlUp).Row


'Start to Loop through each row and perform actions

          For Each cell In .Range("A2:A" & Lrow)

'Create some variables which contain the releavant data.

            PO = cell.Value
            RSD = cell.Offset(0, 10).Value
            Item = cell.Offset(0, 4).Value
            QTY = cell.Offset(0, 2).Value
            Supplier = cell.Offset(0, 6).Value



'Find the supplier email address

    FindString = Supplier
    If Trim(FindString) <> "" Then
        With Sheets("Contacts").Range("A:A")
            Set Rng = .Find(What:=FindString, _
                            After:=.Cells(.Cells.Count), _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)
            If Not Rng Is Nothing Then
                'Email address was found. The Email variable will now reference the email address
                Email = Rng.Offset(0, 1)
            Else
                'Email address not found. Ensure Excel is brought to the foreground and the popup message displayed
                Application.Visible = True
                MsgBox "Supplier not found " & FindString & ", please manually input email address and add to table"
            End If
        End With
    End If


'Find the SentOnBehalfOfName email address

    FindString2 = Supplier
    If Trim(FindString2) <> "" Then
        With Sheets("Contacts").Range("A:A")
            Set Rng2 = .Find(What:=FindString2, _
                            After:=.Cells(.Cells.Count), _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)
            If Not Rng Is Nothing Then
                'Email address was found. The Email2 variable will now reference the email address for the email to be sent from
                Email2 = Rng2.Offset(0, 2)
            Else
                'Do nothing. Assumption is that if a supplier is in the table it should have all details. If not, it will be _
                picked up by the previous error check message.
            End If
        End With
    End If


'Start to create an email session

    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    Set OutMail = OutApp.CreateItem(0)


'Now that we have told Excel that we want to send an email, we need to populate it with data...

    With OutMail
        'If we have a supplier email address then put it in the 'To' field. If not leave blank

            If Not Rng Is Nothing Then .to = Email Else .to = ""
                'If we have a SentOnBehalfOfName email address then put it in the 'SentOnBehalfOfName' field. If not leave blank
                    If Not Rng2 Is Nothing Then .SentOnBehalfOfName = Email2 Else .SentOnBehalfOfName = ""
                        'You can add a cc or bcc using the following fields:
                            .CC = ""
                            .BCC = ""
        'Subject of the email. This is populated with static text within "". And the Variable 'SO'

            .Subject = "Purchase Order# " & PO & " - Missing Booking"

        'Body of email. Again static text is in "" and the use of variables to pull throuh shipment data from the source _
        You can create new blank lines using the code '"" & vbNewLine &'
            .Body = "Dear Supplier," & vbNewLine & vbNewLine & _
                  "Our records state that our Bookings Team has not received your HRG Booking" & _
                  " for the below Purchase Orders. Please can you " & _
                  "reply to this email with the booking form within 48 hours" & vbNewLine & _
                  "Purchase Order: " & PO & vbNewLine & _
                  "Revised Ship Date: " & RSD & vbNewLine & _
                  "Item Desc.: " & Item & vbNewLine & _
                  "Order Qty: " & QTY & vbNewLine & _
                  "Kind regards, " & vbNewLine & _
                  "DHL - HRG Control Tower"

'Uncomment the following line to make the email automatically send if both 'To' & 'SentOnBehalfOfName' email addresses have been found _
        If you do this either delete or comment out the line after which is just '.Display'


                If .to = "" And .SentOnBehalfOfName = "" Then .Display Else .Send
                '.Display


'Tell Excel we've finished creating our email and want to return to the Excel VBA process

    End With
        Set OutMail = Nothing
            Set OutApp = Nothing


'Go to the next row in the table and start again. If the last row has been processed the 'End With' will be actioned

        Next cell
            End With


'Delete all data from the 'Data' tab ready to be started afresh next time
    'ws1.Cells.Delete


' Re-enable screen updating, alerts, calculation etc
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.Calculation = xlAutomatic
End Sub