How to Loop Through A Table Column to Filter Another Table to Send Each Filtered Table By Email?

Question

I am trying to:

• Use a value from Table A (column - person's name) to filter on Table B in separate sheet
• Copy filtered Table B into the body of an email (outlook)
• Send outlook email to email address for that recipient (from Table A)
• Loop through the process again for the next person in Table A

Example of Table A:

Example of Table B:

So for example for the first iteration

• Take Dave Jones from Table A and filter Table B for Dave Jones.
• Copy the filtered Table B to the body of a new email
• Send to Dave Jones (davejones@davejones.com).
• Return to Table A for the next entry, in this case Anne Smith, and do the same. Repeat until the end of Table A.

I made code for setting up an email but this takes the whole worksheet and does not do any filtering. I am unable to work out how to put this loop together for multiple emails:

Sub SendWorkSheet_SENDEMAILS1()
    Dim xFile As String
    Dim xFormat As Long
    Dim Wb As Workbook
    Dim Wb2 As Workbook
    Dim FilePath As String
    Dim FileName As String
    Dim OutlookApp As Object
    Dim OutlookMail As Object

    On Error Resume Next

    Application.ScreenUpdating = False
    Set Wb = Application.ActiveWorkbook
    ActiveSheet.Copy
    Set Wb2 = Application.ActiveWorkbook
    Select Case Wb.FileFormat
    Case xlOpenXMLWorkbook:
        xFile = ".xlsx"
        xFormat = xlOpenXMLWorkbook
    Case xlOpenXMLWorkbookMacroEnabled:
        If Wb2.HasVBProject Then
            xFile = ".xlsm"
            xFormat = xlOpenXMLWorkbookMacroEnabled
        Else
            xFile = ".xlsx"
            xFormat = xlOpenXMLWorkbook
        End If
    Case Excel8:
        xFile = ".xls"
        xFormat = Excel8
    Case xlExcel12:
        xFile = ".xlsb"
        xFormat = xlExcel12
    End Select
    FilePath = Environ$("temp") & "\"
    FileName = Wb.name & Format(Now, "dd-mmm-yy h-mm-ss")
    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookMail = OutlookApp.CreateItem(0)
    Wb2.SaveAs FilePath & FileName & xFile, FileFormat:=xFormat
    With OutlookMail
        .to = "EMAIL ADDRESS HERE"
        .CC = ""
        .BCC = ""
        .Subject = "Suppliers"
        .HTMLBody = "Hi all," & "<br>" & "<br>" & "Please find attached etc. etc." & "<br>" & "<br>" & "Kind regards," & "<br>" & "<br>" & "Sender"
        '.Body = ""
            .Attachments.Add Wb2.FullName
        .Display
        '.Send
    End With
    Wb2.Close
    Kill FilePath & FileName & xFile
    Set OutlookMail = Nothing
    Set OutlookApp = Nothing
    Application.ScreenUpdating = True
End Sub

Answer 1

I’ve had the need to do the task you describe a number of times in the past, and the following was the solution I came up with. Great credit to Sigma Coding at https://www.youtube.com/watch?v=ZlInSp0-MdU&ab_channel=SigmaCoding for providing the bulk of the code – the Loop and Filter stuff I added for my own specific application.

For the following to work, you need to enable a couple of references within VBA. In the VBA Editor, select Tools/References & check the boxes ‘Microsoft Outlook 16.0 Object Library’ and ‘Microsoft Word 16.0 Object Library’. If they’re not already checked, you’ll find them listed alphabetically.

The following code suggestion assumes the following:

• The Managers’ list is on Sheet1 and the range they are contained in is called “MyRange”

• The table to filter is on Sheet2 and starts from cell A1

This code works for me – let me know how you go with it.

Option Explicit
Dim Outlook As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim OutInspect As Outlook.Inspector
Dim EmailTo As String

Dim OutWrdDoc As Word.Document
Dim OutWrdRng As Word.Range
Dim OutWrdTbl As Word.Table

Dim rng As Range, c As Range, MyRange As Range, myFilter As String

Sub TestEmail()

For Each c In Sheet1.Range("MyRange")

    myFilter = c.Value
    EmailTo = c.Offset(0, 1).Value
    
    Sheet2.Range("A1:E1").AutoFilter Field:=2, Criteria1:="=" & myFilter
    
'ERROR TRAP 
If EmailTo = "" Or Sheet2.Cells.SpecialCells(xlCellTypeVisible).Rows.Count = 1 Then
    GoTo Missing:
End If

    Set rng = Sheet2.Cells.SpecialCells(xlCellTypeVisible)

On Error Resume Next

Set Outlook = GetObject(, "Outlook.Application")
    
    If Err.Number = 429 Then
    Set Outlook = New Outlook.Application
    End If
    
Set OutMail = Outlook.CreateItem(olMailItem)

With OutMail
            .To = EmailTo
            .Subject = "Suppliers"
            .Body = "Please find attached etc."
                       
            .Display
            
            Set OutInspect = .GetInspector
            Set OutWrdDoc = OutInspect.WordEditor
            
            rng.Copy
            Set OutWrdRng = OutWrdDoc.Application.ActiveDocument.Content
                OutWrdRng.Collapse Direction:=wdCollapseEnd
            
            Set OutWrdRng = OutWrdDoc.Paragraphs.Add
                OutWrdRng.InsertBreak
            
            OutWrdRng.PasteExcelTable Linkedtoexcel:=True, wordformatting:=True, RTF:=True
            
            Set OutWrdTbl = OutWrdDoc.Tables(1)
            
                OutWrdTbl.AllowAutoFit = True
                OutWrdTbl.AutoFitBehavior (wdAutoFitWindow)
            
            .Send
            
        Application.CutCopyMode = False
        Sheet2.AutoFilterMode = False
        
        End With

Missing:
Next c

End Sub