Send Email to Specific Vendor

[JERRY89]

Dear All,

I have an Excel generate from my Accounting Software, but i facing problem where i need to manually send the Statement One by One to each supplier to request them to send theirs Statement, so is there a possibility where it could automatically generate Individual supplier Statement and send out to them. I had attached my problem as below. Beside that I have another Excel file where column A is supplier Name & Column B is supplier email so can i use this as a base to detect the correct supplier name and send to them. Basically monthly i have more than 200 hundred supplier where i need to manually crop and send.

[HansV]

Do you want to send the statement as an Excel attachment? Or as a PDF attachment? Or in the body of the email?

[JERRY89]

Hi Hans,

I want to send as an Excel Attachment.

[HansV]

I'll get back to you, but it'll take time.

[HansV]

Here is a macro you can run. It assumes that

1) The workbook with the list of email addresses is named MailList.xlsx (you can change this in the code).
2) The workbook with the list of email addresses is open in Excel.
3) The workbook with the statements is the active workbook.

Code: Select all

Sub SendMail()
    Dim r As Long
    Dim r0 As Long
    Dim m As Long
    Dim wbkM As Workbook
    Dim wshM As Worksheet
    Dim wbkS As Workbook
    Dim wshS As Worksheet
    Dim wbkT As Workbook
    Dim wshT As Worksheet
    Dim objOL As Object
    Dim objMsg As Object
    Dim strVendor As String
    Dim rngFound As Range
    Dim strEmail As String
    Dim strPath As String
    Dim strFile As String
    Application.ScreenUpdating = False
    ' Outlook
    Set objOL = CreateObject("Outlook.Application")
    ' Workbook with statements
    Set wbkS = ActiveWorkbook
    Set wshS = wbkS.Worksheets(1)
    strPath = wbkS.Path & "\"
    ' Workbook with email addresses
    Set wbkM = Workbooks("MailList.xlsx")
    Set wshM = wbkM.Worksheets(1)
    ' Loop through the statement rows
    m = wshS.Range("B" & wshS.Rows.Count).End(xlUp).Row
    For r = 4 To m + 2
        If wshS.Range("B" & r).Value <> "" Or r = m + 2 Then
            If wshS.Range("B" & r).Value <> strVendor Or r = m + 2 Then
                If strVendor <> "" Then
                    ' Find email address
                    Set rngFound = wshM.Range("A:A").Find(What:=strVendor, LookAt:=xlWhole)
                    If Not rngFound Is Nothing Then
                        strEmail = rngFound.Offset(0, 1).Value
                        If strEmail <> "" Then
                            ' Create new workbook
                            Set wbkT = Workbooks.Add(xlWBATWorksheet)
                            Set wshT = wbkT.Worksheets(1)
                            ' Copy data
                            wshS.Range("B3:F3").Copy Destination:=wshT.Range("A1")
                            wshS.Range("B" & r0 & ":F" & r - 1).Copy Destination:=wshT.Range("A2")
                            wshT.Range("A1:E1").EntireColumn.AutoFit
                            ' Save new workbook
                            strFile = strPath & strVendor & ".xlsx"
                            wbkT.SaveAs Filename:=strFile, FileFormat:=xlOpenXMLWorkbook
                            wbkT.Close
                            DoEvents
                            ' Email
                            Set objMsg = objOL.CreateItem(0)
                            With objMsg
                                .Subject = wshS.Range("B1").Value & " - " & strVendor
                                .Body = "Please do send latest SOA to us"
                                .To = strEmail
                                .Attachments.Add strFile
                                .Display
                            End With
                            DoEvents
                            ' Optional: delete the new workbook
                            Kill strFile
                        End If
                    End If
                End If
                r0 = r
                strVendor = wshS.Range("B" & r).Value
            End If
        End If
    Next r
    Application.ScreenUpdating = True
End Sub

[JERRY89]

Hi Hans,

Thanks alot.. I still doing testing..

[JERRY89]

Hi Hans,

Thanks for your guidance, after I test my original file in my company, it work perfectly.

[HansV]

Good to hear that!