Excel VBA遍历指定Range动态更新工作表引用实现批量导出发邮件

需求背景 #

现有包含100+个工作表的Excel文档，原有两个功能宏需要针对每个工作表单独编写，效率极低，需合并为通用宏实现批量自动处理：

1. 第一个宏功能：从固定数据源工作表Sheet121筛选匹配数据，写入目标报表工作表
2. 第二个宏功能：将目标报表工作表导出为PDF，调用Outlook自动发送邮件
3. 触发逻辑：遍历指定范围B6:B123，若单元格值不等于0，取同一行D列存储的工作表CodeName作为目标报表表，执行上述两个宏的逻辑

通用合并宏代码 #

Sub BatchProcessReportsAndSendEmails()
    ' 声明变量
    Dim datasheet As Worksheet
    Dim targetSheet As Worksheet
    Dim ocname As String
    Dim finalrow As Integer
    Dim i As Integer
    Dim wPath As String, wFile As String, wMonth As String, strPath As String
    Dim dam As Object
    Dim traverseRange As Range, cell As Range
    Dim ws As Worksheet
    
    ' 固定配置项，无需修改
    Set datasheet = Sheet121 ' 固定数据源表
    wMonth = Sheets("Journal").Range("K2").Value ' 统一取Journal表的月份
    wPath = ThisWorkbook.Path & IIf(Right(ThisWorkbook.Path, 1) = "\", "", "\") ' 修正原代码路径重复赋值问题
    ' 遍历范围，若遍历的是固定工作表可改为 Sheets("对应表名").Range("B6:B123")
    Set traverseRange = ActiveSheet.Range("B6:B123")
    
    ' 遍历触发范围
    For Each cell In traverseRange
        If cell.Value <> 0 Then
            ' 取同一行D列的工作表CodeName匹配目标报表表
            targetSheetCode = cell.Offset(0, 2).Value ' B列右移2列即为D列
            Set targetSheet = Nothing
            ' 匹配对应工作表
            For Each ws In ThisWorkbook.Worksheets
                If ws.CodeName = targetSheetCode Then
                    Set targetSheet = ws
                    Exit For
                End If
            Next ws
            ' 未找到对应工作表则跳过
            If targetSheet Is Nothing Then GoTo NextCell
            
            ' ---------------------- 原Macro1逻辑 ----------------------
            ocname = targetSheet.Range("A1").Value
            targetSheet.Range("A1:U499").EntireRow.Hidden = False
            targetSheet.Range("A5:U499").ClearContents
            
            datasheet.Select
            finalrow = datasheet.Cells(datasheet.Rows.Count, 1).End(xlUp).Row
            For i = 2 To finalrow
                If datasheet.Cells(i, 1) = ocname Then
                    datasheet.Range(datasheet.Cells(i, 1), datasheet.Cells(i, 21)).Copy
                    targetSheet.Range("A500").End(xlUp).Offset(1, 0).PasteSpecial xlPasteAll
                End If
            Next i
            targetSheet.Select
            Range("A4").Select
            Call HideRows ' 需保证原有HideRows宏存在
            
            ' ---------------------- 原Macro2逻辑 ----------------------
            wFile = targetSheet.Range("A1").Value & ".pdf"
            strPath = wPath & wFile
            targetSheet.Range("A1:U500").ExportAsFixedFormat Type:=xlTypePDF, Filename:=strPath, _
                Quality:=xlQualityStandard, IncludeDocProperties:=True, _
                IgnorePrintAreas:=False, OpenAfterPublish:=False
            
            Set dam = CreateObject("Outlook.Application").CreateItem(0)
            dam.To = targetSheet.Range("A2").Value
            dam.cc = targetSheet.Range("A3").Value
            dam.Subject = "Statement " & wMonth
            dam.Body = "Hi" & vbNewLine & vbNewLine & "Please find attached your statement." & Chr(13) & Chr(13) & "Regards," & Chr(13) & "xxxxx"
            dam.Attachments.Add strPath
            dam.Send
            MsgBox targetSheet.Name & " 邮件已发送"
        End If
NextCell:
    Next cell
End Sub

注意事项 #

• 确保原有HideRows宏可正常调用，若不需要可以删除对应行
• 若遍历范围固定为某个工作表（比如Journal表），可以将Set traverseRange = ActiveSheet.Range("B6:B123")修改为Set traverseRange = Sheets("Journal").Range("B6:B123")
• 代码已修正原宏中wPath重复赋值的笔误，自动补全路径末尾的斜杠，避免导出PDF失败
• 所有目标工作表的A1存客户名称、A2存收件人邮箱、A3存抄送人邮箱的结构要和原有规则保持一致

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