Question

我正在尝试编写一个VBA代码，该代码将自动向多个收件人发送文档。我的Excel电子表格如下所示：

    Name    Report #1   Report #2   Report #3
Recipient   Email 1     Email 1     Email 1
            Email 2     Email 2     Email 2
            Email 3     Email 3     Email 3
            Email 4                 Email 4
            Email 5

代码使用单元格B1查找报告名称并在驱动器上找到它。然后将其作为附件发送给B列中的收件人。到目前为止，我已经能够做到这一点：

Option Explicit

Sub Email_Report()

'Purpose: AustrTomate sending of reports via email to a list of specified Recipients

Dim OutApp As Object
Dim OutMail As Object
Dim EmailRng As Range, Recipient As Range
Dim strTo As String

Set EmailRng = Worksheets("Sheets1").Range("B2:B20")

    For Each Recipient In EmailRng
        strTo = strTo & ";" & Recipient.Value
    Next

    strTo = Mid(strTo, 2)
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next

        With OutMail
           .strTo = strTo
           .CC = ""
           .BCC = ""
           .Subject = "Report Name Here"

           .Body = "Body text here"

           .Attachments.Add ("File location here")
           .Send
        End With

    On Error GoTo 0

    Set OutMail = Nothing
    Set OutApp = Nothing



End Sub

但我很难找到一个优雅的解决方案，让代码继续使用C，D等列来做同样的事情。任何人都可以把我推向正确的方向吗？

Answer 1

尝试使用类似的内容替换For Each语句。这将滚动第二行中的单元格，所以我猜你需要添加另一个循环来滚动所有行，一旦你有这个工作。

注意：我将To切换为strTo，因为To给了我一个错误。它是VBA中的保留关键字。

获取电子邮件的新循环：

For column = 2 To EmailRng.Cells.Count
    If Cells(2, column) <> "" Then 'Don't bother cell is blank
        'Don't add a semicolon with the first address
        If strTo = "" Then
            strTo = Cells(2, column)
        Else
            strTo = strTo & ";" & Cells(2, column)
        End If
    End If
Next

Answer 2

您不需要循环收件人，使用Join with加入值;像这样的分隔符：

Sub Email_Report()

'Purpose: AustrTomate sending of reports via email to a list of specified Recipients

Dim OutApp As Object, OutMail As Object, EmailRng As Range, Recipient As Range, strTo As String, X As Long

Set EmailRng = Worksheets("Sheets1").Range("B2:B20")
Set OutApp = CreateObject("Outlook.Application")
    For X = 1 To 3 'Number of columns to poll across
        strTo = Join(Application.Transpose(Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row).Offset(0, X - 1)), ";") 'Get all values in column and populate to strTo without looping
        Set OutMail = OutApp.CreateItem(0)
        On Error Resume Next
            With OutMail
               .strTo = strTo
               .CC = ""
               .BCC = ""
               .Subject = "Report Name Here"
               .Body = "Body text here"
               .Attachments.Add ("File location here")
               .Send
            End With
        On Error GoTo 0
        Set OutMail = Nothing
    Next
Set OutApp = Nothing
End Sub

循环遍历每一列

2 个答案: