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
CLICK HERE to find out more related problems solutions.