vba - 如何将Excel工作表附加到Outlook电子邮件？

我正在尝试解决一个附加文件的问题。

我有一个表，其中包含人员及其姓名和条件（Y / N）列。

第1栏（名称）第2栏（电子邮件）第3栏（条件是/否）  

我想向表中名称与表单1中一列中的唯一值（名称）相匹配的所有人发送电子邮件。

因此，我希望可以在工作表1中查找该列，并可能将在工作表1中该列中找到的所有唯一名称的条件更改为TABLE中的Y（我可以在POWER QUERY中过滤表以仅显示具有条件的行“ Y”）。

当弹出单个电子邮件（“收件人”中的所有人）时，我希望将工作表1或工作表2附加到电子邮件中。

Option Explicit

Public Sub SendEmail()
    ' For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
    ' Working in Office 2000-2016
    ' Adapted by Ricardo Diaz ricardodiaz.co

    Dim OutApp As Object
    Dim OutMail As Object
    Dim sourceTable As ListObject
    Dim evalRow As ListRow

    Dim counter As Long
    Dim toArray() As Variant

    Application.ScreenUpdating = False

    Set OutApp = CreateObject("Outlook.Application")

    Set sourceTable = Range("Table6").ListObject ' -> Set the table's name

    On Error GoTo cleanup

    ' Loop through each table's rows
    For Each evalRow In sourceTable.ListRows

        If evalRow.Range.Cells(, 2).Value Like "?*@?*.?*" And _
          LCase(evalRow.Range.Cells(, 3).Value) = "yes" Then
            ReDim Preserve toArray(counter)
            toArray(counter) = evalRow.Range.Cells(, 2).Value
            counter = counter + 1
        End If

    Next evalRow

    ' Setup the email
    Set OutMail = OutApp.CreateItem(0)
    On Error Resume Next

    With OutMail
        ' Add gathered recipients
        For counter = 0 To UBound(toArray)
            .Recipients.Add (toArray(counter))
        Next counter

        .Subject = "Reminder"

        .Body = "Dear All" _
                & vbNewLine & vbNewLine & _
                "Please comply with the transfers in the attached file. " & _
                "Look up for your store and process asap."

        'You can add files also like this
        '.Attachments.Add ("C:\test.txt") ' -> Adjust this path

        .Display     ' -> Or use Display
    End With

    On Error GoTo 0
    Set OutMail = Nothing

cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True
End Sub

附加工作表1的代码（无效）

file_name_import = Format(Now, "yyyy-mm-dd hh-mm-ss")
file_name_import = file_name_import & " - File 1.xlsx"

Worksheets("Sheet 1").Copy
ChDir "H:\Folder 1\Folder 2\Folder 3\Folder 4\"
ActiveWorkbook.SaveAs Filename:= _
  "H:\Folder 1\Folder 2\Folder 3\Folder 4\File 1" & file_name_import, _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

.Attachments.Add "H:\Folder 1\Folder 2\Folder 3\Folder 4\File 1\" & file_name_import

我想添加代码，以便我的电子邮件与附件一起弹出（“收件人”中的所有必填人员）。