根据列中的条件向具有（不同）多个附件的收件人发送电子邮件

Question

我目前正在尝试编写一个宏，它会根据每个列的名称旁边是否有 X 来将多个附件通过电子邮件发送给收件人。 我在 G 列中有电子邮件地址，在 H:R 列中有 11 个不同的报告名称。

到目前为止，我已经编写了一个宏，如果电子邮件收件人在列 H 中有 X，它将发送附件（报告 1） ，但我不确定如何编写宏，因此它会在列 H:R 中搜索 X 并发送相应的报告（即，如果电子邮件收件人有 >X 在列 H 和列 J 然后我希望他们同时收到 Report 1 和 Report 3 em> 在同一封电子邮件中）。

对不起，如果我的解释难以解释。
非常感谢任何帮助

Private Sub CommandButton1_Click()

    Dim OutApp As Object
    Dim OutMail As Object
    Dim sh As Worksheet
    Dim cell As Range
    Dim FileCell As Range
    Dim rng As Range


    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set sh = Sheets("Contacts")

    Set OutApp = CreateObject("Outlook.Application")

    For Each cell In sh.Columns("G").Cells.SpecialCells(xlCellTypeConstants)

        If cell.Value Like "?*@?*.?*" And _
            LCase(Cells(cell.Row, "H").Value) = "x" Then
            Set OutMail = OutApp.CreateItem(0)

            With OutMail
                .to = cell.Value
                .Subject = "Report 1"
                .body = "Hi " & cell.Offset(0, -3).Value
            'Link file path for attachment
                .Attachments.Add ("C:\Users\smcelroy021218\Desktop\Email Macro Working.xlsm")
                .Display
            End With

            Set OutMail = Nothing
        End If
    Next cell

    Set OutApp = Nothing
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

Answer 1

你没有说文件路径来自哪里：在这个例子中，我从你的工作表的第一行（所以从 H1:R1）中挑选它们。

Private Sub CommandButton1_Click()

    Dim OutApp As Object
    Dim OutMail As Object
    Dim sh As Worksheet
    Dim cell As Range, c As Range
    Dim FileCell As Range
    Dim rng As Range, rngAttach As Range

    Set sh = Sheets("Contacts")

    Set OutApp = CreateObject("Outlook.Application")

    For Each cell In sh.Columns("G").Cells.SpecialCells(xlCellTypeConstants)

        Set rngAttach = cell.Offset(0, 7).Resize(1, 11)

        'EDIT: must have at least one attachment to create a mail
        If cell.Value Like "?*@?*.?*" And _
                          Application.Countif(rngAttach, "x") > 0 Then

            Set OutMail = OutApp.CreateItem(0)

            With OutMail
                .to = cell.Value
                .Subject = "Report 1"
                .body = "Hi " & cell.Offset(0, -3).Value

                'loop over H:R and check for "x"
                For Each c In rngAttach.Cells
                    If LCase(Trim(c.Value)) = "x" Then
                        'pick up the file path from the top row of the sheet
                        .Attachments.Add sh.Cells(1, c.Column).Value
                    End If
                Next c

                .Display
            End With

            Set OutMail = Nothing

        End If
    Next cell

    Set OutApp = Nothing

End Sub