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

Question

我正在尝试:

• 使用表 A(列 - 人员姓名)中的值在单独的工作表中过滤表 B
• 将过滤后的表 B 复制到电子邮件正文(Outlook)
• 将 Outlook 电子邮件发送到该收件人的电子邮件地址(来自表 A)
• 再次循环执行该流程，查找表 A 中的下一个人

表 A 示例:

表 B 的示例:

例如，对于第一次迭代

• 从表 A 中选取 Dave Jones，并在表 B 中筛选出 Dave Jones。
• 将过滤后的表 B 复制到新电子邮件的正文
• 发送给戴夫·琼斯 ([email protected])。
• 返回表 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