如何用Excel VBA按工作表名称批量发送拆分表给对应审阅人？

核心需求 #

已将主工作表按审阅人名称拆分为独立工作表，需批量将每个工作表以表名为依据发送给对应邮箱（如表名raj发送至raj@gmail.com），现有单表发送VBA代码，需修改实现批量功能。

修改思路 #

• 建立工作表名与邮箱的映射关系，用字典存储便于灵活维护
• 遍历所有目标工作表，跳过无需发送的表（如主表）
• 仅初始化一次Outlook对象，提升运行效率
• 统一处理临时文件的生成、发送后清理

修改后的完整代码 #

Sub BatchEmailWorksheets()
    Dim oApp As Object
    Dim oMail As Object
    Dim WB As Workbook
    Dim FileName As String
    Dim wSht As Worksheet
    Dim CurrDate As String
    Dim emailDict As Object '存储表名与对应邮箱的映射字典
    
    '初始化日期格式
    CurrDate = Format(Date, "MM-DD-YY")
    '创建映射字典，根据实际需求添加更多表名和邮箱
    Set emailDict = CreateObject("Scripting.Dictionary")
    emailDict("raj") = "raj@gmail.com"
    emailDict("alice") = "alice@gmail.com"
    emailDict("bob") = "bob@gmail.com"
    
    Application.ScreenUpdating = False
    '仅初始化一次Outlook对象
    Set oApp = CreateObject("Outlook.Application")
    
    '遍历当前工作簿的所有工作表
    For Each wSht In ThisWorkbook.Worksheets
        '仅处理字典中存在的目标工作表
        If emailDict.Exists(wSht.Name) Then
            '复制当前工作表到新工作簿
            wSht.Copy
            Set WB = ActiveWorkbook
            
            '生成临时文件路径和名称
            FileName = wSht.Name & " " & CurrDate & ".xlsx"
            Dim tempPath As String
            tempPath = "C:\Users\Desktop\workfiles\" & FileName
            
            '删除已存在的同名临时文件
            On Error Resume Next
            Kill tempPath
            On Error GoTo 0
            
            '保存临时文件
            WB.SaveAs FileName:=tempPath, FileFormat:=xlOpenXMLWorkbook
            
            '创建并配置邮件
            Set oMail = oApp.CreateItem(0)
            With oMail
                .To = emailDict(wSht.Name)
                .Subject = "工作文件：" & wSht.Name & " " & CurrDate
                .Body = "Hi " & wSht.Name & vbCrLf & vbCrLf & _
                        "请查收附件中的工作文件。"
                .Attachments.Add WB.FullName
                .Display '若需自动发送而非显示，替换为.Send
            End With
            
            '清理临时文件与工作簿
            WB.Close SaveChanges:=False
            Kill tempPath
            
            '释放邮件对象
            Set oMail = Nothing
        End If
    Next wSht
    
    '恢复系统设置并释放所有对象
    Application.ScreenUpdating = True
    Set oApp = Nothing
    Set emailDict = Nothing
    
    MsgBox "批量邮件发送完成！", vbInformation
End Sub

关键说明 #

• 映射字典维护：在emailDict中补充所有需要发送的表名和对应邮箱即可扩展范围
• 跳过非目标表：通过字典判断过滤无关工作表，避免误发主表或其他辅助表
• 临时文件清理：发送完成后立即删除临时文件，避免占用本地存储空间
• 发送模式切换：将.Display替换为.Send可实现自动发送（需确保Outlook已完成账号配置）

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