excel - 如何循环遍历一个表列以过滤另一个表以通过电子邮件发送每个过滤后的表？

Question

我在尝试着:

使用表 A 中的值(列 - 人名)在单独的工作表中过滤表 B

将过滤后的表 B 复制到电子邮件正文中(outlook)

将 Outlook 电子邮件发送到该收件人的电子邮件地址(来自表 A)

为表 A 中的下一个人再次循环该过程

表 A 示例:

表 B 示例:

例如，对于第一次迭代

从表 A 中获取 Dave Jones，并为 Dave Jones 过滤表 B。

将过滤后的表 B 复制到新电子邮件的正文

发送给戴夫琼斯 (davejones@davejones.com)。

返回表 A 以获取下一个条目，在本例中为 Anne Smith，并执行相同操作。重复直到表 A 结束。

我编写了用于设置电子邮件的代码，但这需要整个工作表并且不进行任何过滤。我无法弄清楚如何将这个循环放在一起处理多封电子邮件:

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

我过去曾多次需要执行您描述的任务，以下是我提出的解决方案。非常感谢 Sigma Coding 在 https://www.youtube.com/watch?v=ZlInSp0-MdU&ab_channel=SigmaCoding
用于提供大部分代码——我为自己的特定应用程序添加的循环和过滤器。
为了使以下工作，您需要在 VBA 中启用几个引用。在 VBA 编辑器中，选择工具/引用并选中“Microsoft Outlook 16.0 对象库”和“Microsoft Word 16.0 对象库”复选框。如果尚未检查它们，您会发现它们按字母顺序列出。
以下代码建议假设如下:
• 经理名单在 Sheet1 上，他们所在的范围称为“MyRange”
• 要过滤的表格在 Sheet2 上并从单元格 A1 开始
这段代码对我有用——让我知道你是如何使用它的。

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