how can i loop through a table column to filter another table and send each selected table by email?

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 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
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."
            Set OutInspect = .GetInspector
            Set OutWrdDoc = OutInspect.WordEditor
            Set OutWrdRng = OutWrdDoc.Application.ActiveDocument.Content
                OutWrdRng.Collapse Direction:=wdCollapseEnd
            Set OutWrdRng = OutWrdDoc.Paragraphs.Add
            OutWrdRng.PasteExcelTable Linkedtoexcel:=True, wordformatting:=True, RTF:=True
            Set OutWrdTbl = OutWrdDoc.Tables(1)
                OutWrdTbl.AllowAutoFit = True
                OutWrdTbl.AutoFitBehavior (wdAutoFitWindow)
        Application.CutCopyMode = False
        Sheet2.AutoFilterMode = False
        End With

Next c

End Sub

CLICK HERE to find out more related problems solutions.

Leave a Comment

Your email address will not be published.

Scroll to Top