如何用Excel VBA实现按经理批量发送下属用户角色核验邮件

核心思路 #

• 用**字典（Dictionary）**按经理邮箱分组，自动过滤重复经理邮箱，确保每个经理仅生成一封邮件
• 对同一用户的多角色进行合并，避免邮件中重复展示同一用户
• 定义文本邮件模板，通过替换占位符插入经理专属的下属角色清单，无需手动制作附件

完整代码示例 #

假设你的数据源在Excel工作表Sheet1，列顺序为：A=经理邮箱、B=用户名、C=角色。代码如下：

Sub SendRoleAuditEmails()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim managerDict As Object ' 后期绑定字典，无需额外引用
    Dim managerEmail As String
    Dim userName As String
    Dim userRole As String
    Dim userRolesDict As Object ' 存储单个用户的所有角色，避免重复
    Dim emailTemplate As String
    Dim emailContent As String
    Dim subordinateList As String
    Dim olApp As Object
    Dim olMail As Object
    
    ' 初始化工作表和字典
    Set ws = ThisWorkbook.Sheets("Sheet1")
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    Set managerDict = CreateObject("Scripting.Dictionary")
    Set olApp = CreateObject("Outlook.Application")
    
    ' 定义邮件模板（可按需修改格式和内容）
    emailTemplate = "尊敬的经理：" & vbCrLf & vbCrLf & _
                    "请核验您下属的系统用户角色信息：" & vbCrLf & vbCrLf & _
                    "{{SubordinateList}}" & vbCrLf & vbCrLf & _
                    "请于3个工作日内反馈核验结果。" & vbCrLf & _
                    "系统管理员"
    
    ' 遍历数据源，按经理分组聚合数据
    For i = 2 To lastRow ' 假设第1行为表头
        managerEmail = Trim(ws.Cells(i, "A").Value)
        userName = Trim(ws.Cells(i, "B").Value)
        userRole = Trim(ws.Cells(i, "C").Value)
        
        If managerEmail <> "" And userName <> "" And userRole <> "" Then
            ' 若经理不在字典中，初始化其下属角色存储字典
            If Not managerDict.Exists(managerEmail) Then
                Set userRolesDict = CreateObject("Scripting.Dictionary")
                managerDict.Add managerEmail, userRolesDict
            Else
                Set userRolesDict = managerDict(managerEmail)
            End If
            
            ' 给用户添加角色（自动去重同一用户的重复角色）
            If Not userRolesDict.Exists(userName) Then
                userRolesDict.Add userName, userRole
            Else
                userRolesDict(userName) = userRolesDict(userName) & "、" & userRole
            End If
        End If
    Next i
    
    ' 遍历字典，生成并发送邮件
    For Each managerEmail In managerDict.Keys
        Set userRolesDict = managerDict(managerEmail)
        subordinateList = ""
        
        ' 生成下属角色清单字符串
        For Each userName In userRolesDict.Keys
            subordinateList = subordinateList & "● " & userName & "：" & userRolesDict(userName) & vbCrLf
        Next userName
        
        ' 替换模板占位符
        emailContent = Replace(emailTemplate, "{{SubordinateList}}", subordinateList)
        
        ' 创建并发送邮件
        Set olMail = olApp.CreateItem(0)
        With olMail
            .To = managerEmail
            .Subject = "系统用户角色半年审核核验通知"
            .Body = emailContent
            .Send ' 若需预览邮件，替换为 .Display
        End With
        
        Set olMail = Nothing
    Next managerEmail
    
    ' 清理对象
    Set userRolesDict = Nothing
    Set managerDict = Nothing
    Set olApp = Nothing
    Set ws = Nothing
    
    MsgBox "邮件发送完成！", vbInformation
End Sub

关键代码解释 #

1. 字典分组逻辑：
   • 外层字典managerDict以经理邮箱为键，值为内层字典userRolesDict，自动跳过重复经理邮箱，确保每个经理仅处理一次
2. 角色合并处理：
   • 内层字典userRolesDict确保同一用户的角色不会重复，用顿号合并多角色内容
3. 模板替换机制：
   • 定义emailTemplate字符串，用{{SubordinateList}}作为占位符，替换为生成的专属下属清单
4. 邮件发送流程：
   • 调用Outlook对象模型创建邮件，直接填入模板生成的内容，无需额外制作附件

注意事项 #

• 确保Excel启用宏，且Outlook已登录账号
• 若数据源为CSV/TXT文件，可先导入Excel再运行代码，或基于你已掌握的文件操作基础修改代码直接读取文本文件
• 1300行数据的处理效率：字典操作属于O(n)复杂度，无性能问题
• 可根据实际需求调整邮件模板格式、占位符或角色分隔符

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