如何修改VBA代码实现Excel不同单元格范围发送给不同收件人

可行性说明 #

该需求完全可以通过数组（列表）实现，核心逻辑是提前预定义和收件人一一对应的单元格范围集合，遍历收件人时按顺序匹配对应范围即可。

核心修改点 #

• 新增索引变量记录当前遍历的收件人序号
• 新增数组存储所有收件人对应的单元格范围，按收件人选择顺序排列
• 新增校验逻辑，确保选中的收件人数量和预定义的范围数量一致，避免索引越界报错
• 优化Outlook对象创建逻辑，从循环内移到循环外，减少重复创建开销
• 替换原固定的Source范围为按索引从数组中提取的对应范围

修改后完整代码 #

Sub Report()
    Dim Source As Range
    Dim xTxt As String
    Dim Dest As Workbook
    Dim wb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim OutApp As Object
    Dim OutMail As Object
    Dim xRg As Range
    Dim cell As Object
    ' 新增变量：范围数组、当前收件人索引
    Dim arrRanges As Variant
    Dim i As Integer
    
    ' --------------------------配置区：按实际需求修改对应范围--------------------------
    ' 按顺序填入每个收件人对应的单元格范围，和收件人选择顺序一一对应
    arrRanges = Array("A5:K20", "A24:K50", "A55:K80") ' 可继续新增更多范围
    ' --------------------------------------------------------------------------------
    
    Set xRg = Application.InputBox("请选择收件人地址列表:", "选择收件人", xTxt, , , , , 8)
    
    ' 校验收件人数量和范围数量是否匹配
    If xRg.Cells.Count <> UBound(arrRanges) + 1 Then
        MsgBox "选中的收件人数量和预定义的附件范围数量不匹配，请检查后重试", vbOKOnly
        Exit Sub
    End If
    
    ' 提前创建Outlook对象，不用每次循环重复创建
    Set OutApp = CreateObject("Outlook.Application")
    
    i = 0 ' 索引从0开始，对应数组第一个元素
    For Each cell In xRg
        Set Source = Nothing
        On Error Resume Next
        ' 替换原固定范围，按索引取数组中对应的范围，仅保留可见单元格
        Set Source = Range(arrRanges(i)).SpecialCells(xlCellTypeVisible)
        On Error GoTo 0

        If Source Is Nothing Then
            MsgBox "第" & i + 1 & "个收件人对应的范围无效或工作表受保护，请修正后重试", vbOKOnly
            GoTo NextLoop ' 跳过当前收件人，继续处理下一个
        End If

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

        Set wb = ActiveWorkbook
        Set Dest = Workbooks.Add(xlWBATWorksheet)

        ' 复制范围到新工作簿
        Source.Copy
        With Dest.Sheets(1)
            .Cells(1).PasteSpecial Paste:=8 ' 粘贴列宽
            .Cells(1).PasteSpecial Paste:=xlPasteValues ' 粘贴值
            .Cells(1).PasteSpecial Paste:=xlPasteFormats ' 粘贴格式
            .Cells(1).Select
            Application.CutCopyMode = False
        End With

        ' 临时文件配置
        TempFilePath = Environ$("temp") & "\"
        TempFileName = "收件人" & i + 1 & "_" & Format(Now, "dd-mmm-yy h-mm-ss") ' 文件名增加收件人标识，避免重名

        ' 适配Excel版本的文件格式
        If Val(Application.Version) < 12 Then
            ' Excel 97-2003版本
            FileExtStr = ".xls": FileFormatNum = -4143
        Else
            ' Excel 2007及以上版本
            FileExtStr = ".xlsx": FileFormatNum = 51
        End If

        Set OutMail = OutApp.CreateItem(0)
        ' 保存临时文件并发送邮件
        With Dest
            .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
            On Error Resume Next
            With OutMail
                .To = cell.Value
                .CC = ""
                .BCC = ""
                .Subject = "对应数据报告" ' 可自定义主题
                .Body = "您好：" & vbCrLf & vbCrLf & "请查收您对应的附件数据。" ' 可自定义正文
                .Attachments.Add Dest.FullName
                .Display ' 如需自动发送改为.Send即可
            End With
            On Error GoTo 0
            .Close savechanges:=False
        End With

        ' 删除临时文件
        Kill TempFilePath & TempFileName & FileExtStr

        Set OutMail = Nothing
NextLoop:
        i = i + 1 ' 索引+1，对应下一个收件人的范围
        With Application
            .ScreenUpdating = True
            .EnableEvents = True
        End With
    Next cell
    
    ' 最后释放Outlook对象
    Set OutApp = Nothing
End Sub

使用说明 #

• 修改代码中arrRanges数组内的范围字符串，按收件人选择顺序依次填入每个收件人对应的单元格范围，数量和收件人数量保持一致即可
• 可自行修改邮件主题、正文内容，如需自动发送将.Display改为.Send即可

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