请求编写Outlook批量发送员工专属Excel数据行的VBA宏

以下是可直接使用的VBA宏，实现按C列员工邮箱（姓名）拆分数据，自动生成带对应数据的Excel附件并通过Outlook发送：

Sub SendEmployeeDataEmails()
    Dim wsMain As Worksheet
    Dim wsNew As Worksheet
    Dim wbTemp As Workbook
    Dim lastRow As Long
    Dim uniqueNames As Collection
    Dim name As Variant
    Dim i As Long
    Dim olApp As Object
    Dim olMail As Object
    Dim tempPath As String
    
    ' 指定主工作表，替换为你的实际表名
    Set wsMain = ThisWorkbook.Worksheets("主工作表")
    lastRow = wsMain.Cells(wsMain.Rows.Count, "C").End(xlUp).Row
    
    ' 提取C列唯一员工姓名（邮箱前缀）
    Set uniqueNames = New Collection
    On Error Resume Next
    For i = 2 To lastRow ' 假设第1行是表头
        uniqueNames.Add wsMain.Cells(i, "C").Value, Key:=CStr(wsMain.Cells(i, "C").Value)
    Next i
    On Error GoTo 0
    
    ' 初始化Outlook对象
    Set olApp = CreateObject("Outlook.Application")
    
    ' 设置临时文件存储路径（系统临时文件夹）
    tempPath = Environ("TEMP") & "\"
    
    ' 遍历每个员工处理数据并发送邮件
    For Each name In uniqueNames
        ' 创建临时工作簿
        Set wbTemp = Workbooks.Add
        Set wsNew = wbTemp.Worksheets(1)
        
        ' 复制表头到新表，保留格式和列宽
        wsMain.Range("A1:AE1").Copy
        wsNew.Range("A1").PasteSpecial Paste:=xlPasteAllUsingSourceTheme
        wsNew.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
        
        ' 筛选当前员工的数据行
        wsMain.Range("A1:AE" & lastRow).AutoFilter Field:=3, Criteria1:=name
        
        ' 复制筛选后的数据（跳过表头）
        wsMain.Range("A2:AE" & lastRow).SpecialCells(xlCellTypeVisible).Copy
        wsNew.Range("A2").PasteSpecial Paste:=xlPasteAllUsingSourceTheme
        
        ' 取消主表筛选状态
        wsMain.AutoFilterMode = False
        
        ' 自动调整新表列宽
        wsNew.Columns("A:AE").AutoFit
        
        ' 保存临时文件
        tempFileName = tempPath & name & "_数据.xlsx"
        Application.DisplayAlerts = False
        wbTemp.SaveAs Filename:=tempFileName, FileFormat:=xlOpenXMLWorkbook
        wbTemp.Close SaveChanges:=False
        Application.DisplayAlerts = True
        
        ' 创建并发送邮件
        Set olMail = olApp.CreateItem(0)
        With olMail
            .To = name & "@yourdomain.com" ' 替换为你的公司邮箱域名
            .Subject = "你的专属业务数据"
            .Body = "您好，附件是您对应的业务数据，请查收。"
            .Attachments.Add tempFileName
            .Send ' 如需预览邮件可改为.Display
        End With
        
        ' 删除临时文件，避免冗余
        Kill tempFileName
    Next name
    
    ' 释放对象资源
    Set olMail = Nothing
    Set olApp = Nothing
    Set wsNew = Nothing
    Set wbTemp = Nothing
    Set wsMain = Nothing
    
    MsgBox "所有邮件已发送完成！", vbInformation
End Sub

关键说明 #

• 去重处理：借助Collection对象自动过滤C列重复的员工姓名，避免重复发送
• 格式保留：使用xlPasteAllUsingSourceTheme复制数据和格式，同时同步列宽保证排版一致
• 临时文件管理：用系统临时文件夹存储生成的附件，发送后自动删除，不占用本地空间
• Outlook集成：采用Late Binding创建Outlook对象，无需手动添加COM引用（若需早期绑定，可添加"Microsoft Outlook XX.X Object Library"引用）

使用注意事项 #

1. 替换代码中的"主工作表"为你的实际主表名称
2. 修改邮箱域名部分"@yourdomain.com"为公司真实域名
3. 启用宏：打开文件时需启用宏，若有安全限制，可在信任中心设置允许宏运行
4. Outlook安全提示：首次运行可能弹出安全警告，选择允许即可

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