Excel VBA实现自动遍历下拉列表生成PDF报表并邮件发送

需求背景 #

我有Excel VBA基础，正在维护一套离职人员遗留的报表系统。这套系统支持通过下拉列表选择企业名称，生成对应PDF报表并自动发送邮件，但目前必须手动逐个选择下拉列表里的400+企业条目，效率极低。现有代码已实现「选中企业→更新报表→生成PDF→添加到邮件」的完整流程，现在需要补充自动遍历所有下拉列表条目、完成当前企业任务后自动切换下一个的VBA代码。

下拉列表说明：位于Report2工作表的C1单元格，选项对应NAMES工作表中列表对象的企业名称列。

现有代码 #

Sub create_and_email_pdf()
' Create a PDF from the current sheet and email it as an attachment through Outlook
Dim EmailSubject As String, EmailSignature As String
Dim CurrentMonth As String, DestFolder As String, PDFFile As String
Dim Email_To As String, Email_CC As String, Email_BCC As String
Dim OpenPDFAfterCreating As Boolean, AlwaysOverwritePDF As Boolean, DisplayEmail As Boolean
Dim OverwritePDF As VbMsgBoxResult
Dim OutlookApp As Object, OutlookMail As Object
Dim Fname As Variant
Dim business As String
Dim Signature As String
Dim vet As String 'var

Dim name As Range 
Dim add As Integer 
Dim brep As Variant 
Dim rep As Worksheet
Dim frep As Worksheet

    business = ThisWorkbook.Worksheets("Report2").Range("$C$1").Text
    EmailSubject = "Your Report - " & business
    OpenPDFAfterCreating = False
    AlwaysOverwritePDF = False
    DisplayEmail = True     
    Set rep = ThisWorkbook.Worksheets("Report2")
    Set frep = ThisWorkbook.Worksheets("NAMES")
    
    Set brep = frep.ListObjects("NAMES").ListColumns(8).DataBodyRange
    
    With frep.Range("brep")
    Set farm = .Find(business, LookIn:=xlValues)
    End With
    
    var = farm.Offset(0, 4)
    Email_To = name.Offset(0, 8)
    Email_CC = name.Offset(0, 9)
    
    Fname = business & " Report " & "2024 " & "(" & var & ")"

    DestFolder = ThisWorkbook.Path  
    
    'Create new PDF file name including path and file extension
    PDFFile = DestFolder & "\" & Fname & ".pdf"

    'If the PDF already exists
    If Len(Dir(PDFFile)) > 0 Then
    
        If AlwaysOverwritePDF = False Then
        
            OverwritePDF = MsgBox(PDFFile & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", vbYesNo + vbQuestion, "File Exists")
        
            On Error Resume Next
            'If you want to overwrite the file then delete the current one
            If OverwritePDF = vbYes Then
    
                Kill PDFFile
        
            Else
    
                MsgBox "OK then, if you don't overwrite the existing PDF, I can't continue." _
                    & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro"
                
                Exit Sub
        
            End If

        Else
        
            On Error Resume Next
            Kill PDFFile
            
        End If
        
        If Err.Number <> 0 Then
        
            MsgBox "Unable to delete existing file.  Please make sure the file is not open or write protected." _
                    & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File"
                
            Exit Sub
        
        End If
            
    End If
  'Create the PDF
    rep.ExportAsFixedFormat _
    Type:=xlTypePDF, _
    Filename:=PDFFile, _
    Quality:=xlQualityStandard, _
    IncludeDocProperties:=False, _
    IgnorePrintAreas:=False, _
    From:=1, _
    To:=6, _
    OpenAfterPublish:=OpenPDFAfterCreating

    'Enter date of PDF file generation on FARMS tab
    farm.Offset(0, 7).Value = Date
    rep.Application.Goto Reference:=Range("A1"), Scroll:=True

    'If no email address, show warning msg
    If Email_To = vbNullString Then
    MsgBox "There is no email address for this farm.", vbOKOnly, "Email address missing"
    End If
       
    'Create an Outlook object and new mail message
    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookMail = OutlookApp.CreateItem(0)
        
    'Display email and specify To, Subject, etc
    With OutlookMail
        
        .Display
        .To = Email_To
        .CC = Email_CC
        .BCC = Email_BCC
        .Subject = EmailSubject
        .Attachments.Add PDFFile
        .HTMLBody = "Dear," & "<br>" & _
                "<br>" & _
                "EMAIL." & "<br>" & _
                "<br>" & _
                "EMAIL." & "<br>" & _
                "<br>" & _
                "EMAIL." & "<br>" & _
                "<br>" & _
                "EMAIL." & "<br>" & _
                "<br>" & _
                "EMAIL." & "<br>" & _
                "<br>" & _
                "EMAIL," & "<br>" & _
                "EMAIL" & "<br>" & _
                "<br>" & _
                "<p style='font-family:calibri;font-size:11'>" & "<b>Disclaimer:-</b>" & "<br>" & _
                "<br>" & _
                "<b>EMAIL." & "<br>" & _
                "<br>" & _
                "EMAIL" & "<br>" & "</p>" & _
                "<br>" & _
                Signature
                 .sendusingaccount OutlookApp.Session.Accounts.Item(2)
       '.send               
    End With
End Sub

批量处理解决方案 #

修改思路 #

1. 将原代码的核心业务逻辑封装为独立子过程，接收企业名称作为参数，避免重复代码
2. 新增批量遍历子过程，从NAMES列表对象中读取所有企业名称，逐个设置到Report2!C1并调用核心子过程
3. 添加错误处理，确保单个企业处理失败不会中断整个批量任务
4. 增加进度提示，方便跟踪400+条目的处理状态

完整代码 #

' 核心子过程：处理单个企业的PDF生成与邮件发送
Sub ProcessSingleBusiness(businessName As String)
    Dim EmailSubject As String
    Dim DestFolder As String, PDFFile As String
    Dim Email_To As String, Email_CC As String
    Dim OpenPDFAfterCreating As Boolean, AlwaysOverwritePDF As Boolean, DisplayEmail As Boolean
    Dim OverwritePDF As VbMsgBoxResult
    Dim OutlookApp As Object, OutlookMail As Object
    Dim Fname As String
    Dim var As String
    Dim farm As Range
    Dim rep As Worksheet, frep As Worksheet
    Dim Signature As String

    ' 初始化参数
    Set rep = ThisWorkbook.Worksheets("Report2")
    Set frep = ThisWorkbook.Worksheets("NAMES")
    OpenPDFAfterCreating = False
    AlwaysOverwritePDF = False
    DisplayEmail = True

    ' 设置当前处理的企业名称到报表单元格
    rep.Range("$C$1").Value = businessName
    ' 强制刷新工作表，确保报表内容更新
    rep.Calculate

    EmailSubject = "Your Report - " & businessName

    ' 从NAMES表中查找当前企业的相关信息
    Set farm = frep.ListObjects("NAMES").ListColumns(8).DataBodyRange.Find(businessName, LookIn:=xlValues)
    If farm Is Nothing Then
        MsgBox "未找到企业「" & businessName & "」的相关数据，跳过处理。", vbExclamation
        Exit Sub
    End If

    var = farm.Offset(0, 4).Value
    Email_To = farm.Offset(0, 8).Value
    Email_CC = farm.Offset(0, 9).Value

    ' 生成PDF文件名
    Fname = businessName & " Report 2024 (" & var & ")"
    DestFolder = ThisWorkbook.Path
    PDFFile = DestFolder & "\" & Fname & ".pdf"

    ' 处理已存在的PDF文件
    If Len(Dir(PDFFile)) > 0 Then
        If Not AlwaysOverwritePDF Then
            OverwritePDF = MsgBox(PDFFile & " 已存在，是否覆盖？", vbYesNo + vbQuestion, "文件已存在")
            If OverwritePDF = vbNo Then
                MsgBox "跳过企业「" & businessName & "」的处理。", vbInformation
                Exit Sub
            End If
        End If
        On Error Resume Next
        Kill PDFFile
        If Err.Number <> 0 Then
            MsgBox "无法删除已有文件，请确保文件未打开或未被保护，跳过企业「" & businessName & "」的处理。", vbCritical
            Exit Sub
        End If
        On Error GoTo 0
    End If

    ' 生成PDF
    rep.ExportAsFixedFormat _
        Type:=xlTypePDF, _
        Filename:=PDFFile, _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=False, _
        IgnorePrintAreas:=False, _
        From:=1, _
        To:=6, _
        OpenAfterPublish:=OpenPDFAfterCreating

    ' 更新生成日期
    farm.Offset(0, 7).Value = Date
    rep.Application.Goto rep.Range("A1"), Scroll:=True

    ' 检查邮箱地址
    If Email_To = vbNullString Then
        MsgBox "企业「" & businessName & "」未设置邮箱地址，跳过邮件发送。", vbExclamation
        Exit Sub
    End If

    ' 发送邮件
    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookMail = OutlookApp.CreateItem(0)

    With OutlookMail
        .Display ' 先显示邮件获取签名
        ' 获取Outlook默认签名
        Signature = .HTMLBody
        .To = Email_To
        .CC = Email_CC
        .Subject = EmailSubject
        .Attachments.Add PDFFile
        ' 重新组合邮件内容与签名
        .HTMLBody = "Dear," & "<br><br>" & _
                    "EMAIL内容请替换为实际文本<br><br>" & _
                    "EMAIL内容请替换为实际文本<br><br>" & _
                    "EMAIL内容请替换为实际文本<br><br>" & _
                    "<p style='font-family:calibri;font-size:11'>" & _
                    "<b>Disclaimer:-</b><br><br>" & _
                    "免责声明内容请替换为实际文本<br><br>" & _
                    "免责声明内容请替换为实际文本</p><br>" & _
                    Signature
        .SendUsingAccount = OutlookApp.Session.Accounts.Item(2)
        '.Send ' 取消注释可自动发送，无需手动点击发送
    End With

    ' 释放对象
    Set OutlookMail = Nothing
    Set OutlookApp = Nothing
End Sub

' 批量遍历子过程：处理所有企业
Sub BatchProcessAllBusinesses()
    Dim wsNames As Worksheet
    Dim loNames As ListObject
    Dim businessCol As ListColumn
    Dim cell As Range
    Dim totalCount As Integer, currentIndex As Integer
    Dim proceed As VbMsgBoxResult

    Set wsNames = ThisWorkbook.Worksheets("NAMES")
    Set loNames = wsNames.ListObjects("NAMES")
    Set businessCol = loNames.ListColumns(8) ' 第8列为企业名称列，根据实际调整

    totalCount = businessCol.DataBodyRange.Rows.Count
    proceed = MsgBox("即将开始处理" & totalCount & "家企业，是否继续？", vbYesNo + vbQuestion, "批量处理确认")
    If proceed = vbNo Then Exit Sub

    currentIndex = 1
    ' 遍历所有企业名称
    For Each cell In businessCol.DataBodyRange
        ' 显示进度
        Application.StatusBar = "正在处理：" & currentIndex & "/" & totalCount & " - " & cell.Value
        ' 处理当前企业
        ProcessSingleBusiness cell.Value
        currentIndex = currentIndex + 1
    Next cell

    Application.StatusBar = False
    MsgBox "所有企业处理完成！", vbInformation
End Sub

使用说明 #

1. 将上述代码替换或添加到原VBA模块中
2. 确保NAMES列表对象的第8列确实是企业名称列，若不是请修改ListColumns(8)中的数字
3. 替换邮件内容中的EMAIL内容请替换为实际文本为你的真实邮件话术
4. 若需要自动发送邮件（无需手动点击），取消OutlookMail.Send的注释，并注释掉.Display（注意：自动发送前请测试确保逻辑正确）
5. 运行BatchProcessAllBusinesses宏即可启动批量处理

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