VBA根据单元格值动态引用工作表 批量发送未达标办事处邮件

核心改动逻辑 #

• 移除原有代码依赖ActiveSheet的手动逐表触发逻辑，改为自动遍历SUMMARY汇总表的有效数据行
• 自动校验每行C列的考核标记，仅对值为FALSE（未达标）的办事处执行PDF导出、邮件创建流程
• 所有工作表引用通过B列存储的办事处名称动态匹配，完全保留原有页面配置、邮件预填充规则
• 新增基础容错逻辑：如果汇总表中填写的工作表名不存在，自动跳过该行避免代码中断
• 优化Outlook实例创建逻辑，避免重复启动程序占用资源

可直接复用的完整代码 #

Sub SendEmailForUnqualifiedOffices()
    Dim Wb As Workbook
    Dim ws As Worksheet
    Dim summaryWs As Worksheet
    Dim FileName As String
    Dim OutlookApp As Object
    Dim OutlookMail As Object
    Dim xIndex As Long
    Dim lastRow As Long
    Dim i As Long
    Dim targetShtName As String
    
    Set Wb = ThisWorkbook
    ' 绑定SUMMARY汇总表
    Set summaryWs = Wb.Sheets("SUMMARY")
    ' 获取B列最后一行有效数据的行号
    lastRow = summaryWs.Cells(summaryWs.Rows.Count, "B").End(xlUp).Row
    
    ' 初始化Outlook应用，优先复用已打开的实例
    On Error Resume Next
    Set OutlookApp = GetObject(, "Outlook.Application")
    If OutlookApp Is Nothing Then Set OutlookApp = CreateObject("Outlook.Application")
    On Error GoTo 0
    
    ' 遍历汇总表数据，默认第1行为表头，从第2行开始循环
    For i = 2 To lastRow
        ' 判定为未达标时执行发信流程
        If summaryWs.Cells(i, "C").Value = False Then
            targetShtName = summaryWs.Cells(i, "B").Value
            ' 校验对应办事处工作表是否存在
            If SheetExists(targetShtName) Then
                Set ws = Wb.Sheets(targetShtName)
                ' 生成PDF临时文件路径
                FileName = Wb.FullName
                xIndex = VBA.InStrRev(FileName, ".")
                If xIndex > 1 Then FileName = VBA.Left(FileName, xIndex - 1)
                FileName = FileName & "_" & ws.Name & ".pdf"
                
                ' 应用原有打印页面设置
                With ws.PageSetup
                    .Orientation = xlLandscape
                    .FitToPagesTall = 1
                    .FitToPagesWide = 1
                End With
                
                ' 导出当前办事处工作表为PDF
                ws.ExportAsFixedFormat Type:=xlTypePDF, FileName:=FileName
                
                ' 创建预填充邮件
                Set OutlookMail = OutlookApp.CreateItem(0)
                With OutlookMail
                    .SentOnBehalfOfName = "abc@xyz.com"
                    .To = ws.Range("J10").Value
                    .CC = ""
                    .BCC = ""
                    .Subject = ws.Range("C1").Value & " Data"
                    .Body = "abcxyz"
                    .Attachments.Add FileName
                    .Display ' 如需无需确认直接自动发送，可将此行替换为 .Send
                End With
                
                ' 删除本地临时PDF文件
                Kill FileName
                Set OutlookMail = Nothing
            End If
        End If
    Next i
    
    ' 释放所有对象
    Set OutlookApp = Nothing
    Set ws = Nothing
    Set summaryWs = Nothing
End Sub

' 辅助函数：检查工作簿内是否存在指定名称的工作表
Function SheetExists(shtName As String, Optional wb As Workbook) As Boolean
    Dim sht As Worksheet
    If wb Is Nothing Then Set wb = ThisWorkbook
    On Error Resume Next
    Set sht = wb.Sheets(shtName)
    On Error GoTo 0
    SheetExists = Not sht Is Nothing
End Function

使用注意事项 #

• 请确认SUMMARY表第1行为表头，办事处名称从B2单元格开始逐行存储，考核结果布尔值存储在同行C列，工作表名需和B列文本完全一致
• 代码默认保留原有.Display逻辑，会逐封弹出待发送邮件窗口供核对内容，确认无误后手动点击发送即可；如果需要跳过确认直接发送，将代码中.Display替换为.Send
• 导出的PDF为临时文件，添加为邮件附件后会自动从本地删除，不会产生冗余文件
• 运行代码前请确保Outlook处于正常可用状态，避免邮件创建失败

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