如何用Excel VBA引用动态表格数据实现Outlook邮件批量发送

你可以通过动态遍历收件人、抄送列的所有非空单元格，拼接成符合Outlook要求的分号分隔邮箱字符串，就能实现人员增减时自动更新收件人列表，无需修改代码。

修改后的完整代码 #

Option Explicit

Sub Send_Email_With_Attachment()    
    Dim emailApplication As Object
    Dim emailItem As Object
    Dim lastRow As Long, i As Long
    Dim toList As String, ccList As String

    Set emailApplication = CreateObject("Outlook.Application")
    Set emailItem = emailApplication.CreateItem(0)

    '计算A列最后一行有内容的行号
    lastRow = Cells(Rows.Count, "A").End(xlUp).Row
    
    '拼接收件人列表
    For i = 2 To lastRow '从第2行开始跳过表头
        If Trim(Cells(i, "A").Value) <> "" Then
            toList = toList & Trim(Cells(i, "A").Value) & ";"
        End If
    Next i
    
    '拼接抄送列表
    lastRow = Cells(Rows.Count, "B").End(xlUp).Row
    For i = 2 To lastRow
        If Trim(Cells(i, "B").Value) <> "" Then
            ccList = ccList & Trim(Cells(i, "B").Value) & ";"
        End If
    Next i

    '日期计算
    Dim lastSunday As Date
    lastSunday = DateAdd("d", 1 - Weekday(Now), Now)

    '构建邮件
    emailItem.To = toList
    emailItem.CC = ccList

    emailItem.Subject = "Training Report  - " & Format(lastSunday, "dd-MM-yyyy")    
    emailItem.Body = "Dear All" & vbCrLf & vbCrLf & "Please find attached the Weekly  Training report." & vbCrLf & vbCrLf & "Kind Regards,"

    ' 此处可添加附件代码
    ' 示例：emailItem.Attachments.Add "C:\你的文件路径\报告.xlsx"

    '显示邮件，可改为.Send直接发送
    emailItem.Display 
End Sub

关键改动说明 #

• 新增了toList和ccList变量，用来存储拼接后的邮箱列表
• 自动计算对应列最后一行有内容的行号，无需手动指定范围，增减人员时自动识别
• 遍历过程中自动跳过空单元格，避免生成无效的邮箱地址
• Outlook会自动忽略末尾多余的分号，无需额外处理

扩展说明 #

如果你的收件人列表存放在Excel的结构化表格（ListObject）中，还可以直接引用表格列的方式遍历，适配性更强，不会因为插入表头行等操作导致范围偏移。

内容的提问来源于stack exchange，提问作者QMAN