Excel VBA批量提取数据并发送Outlook邮件开发需求

需求概述 #

• 数据源：名为All Data的多工作表工作簿，需从其中的Contents工作表（B列为「Names」姓名列）提取指定人员的行数据
• 邮箱对照表：「Performance.xlsm」工作簿内的Staff email工作表，A列存储姓名，B列对应人员邮箱
• 核心流程：
  1. 循环遍历「Staff email」表中的每一位人员
  2. 在「Contents」表中搜索该人员的所有行，提取指定列数据
  3. 将提取的数据生成单独的「Immediate Action Needed.xlsx」文件作为附件
  4. 通过对照表获取邮箱，创建并发送Outlook邮件
  5. 若未找到对应人员数据，则跳过发送
  6. 全部处理完成后，弹窗展示已发送邮件的人员名单

现有手动处理示例代码 #

以下是之前手动复制数据后使用的VBA代码，注释已译为中文：

Sub ExampleCode()
    Dim fCell As Range
    Dim wsSearch As Worksheet
    Dim wsDest As Worksheet
    Dim lastRow As Long
    
    '指定要搜索的工作表
    Set wsSearch = Worksheets("Contents")
    '指定数据目标工作表
    Set wsDest = Worksheets("Johns Actions") 
    
    '关闭屏幕刷新，避免闪烁
    Application.ScreenUpdating = False
    
    '在B列中搜索
    With wsSearch.Range("B:B")
        '查找内容为"finished"的单元格（原代码注释与实际查找值不符，此处保留原代码逻辑）
        Set fCell = .Find(what:="finished", LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
        
        '循环查找直到没有匹配项
        Do Until fCell Is Nothing
            '确定目标工作表的粘贴行
            lastRow = wsDest.Cells(.Rows.Count, "A").End(xlUp).Offset(1).Row
            
            '复制A:O列的值（避免复制条件格式）
            wsSearch.Cells(fCell.Row, "A").Resize(1, 15).Copy
            wsDest.Cells(lastRow, "A").PasteSpecial Paste:=xlPasteValues
            '复制AF:AG列的值到目标表P列开始的位置
            wsSearch.Cells(fCell.Row, "AF").Resize(1, 2).Copy
            wsDest.Cells(lastRow, "P").PasteSpecial Paste:=xlPasteValues
            
            '删除已处理的行
            fCell.EntireRow.Delete
            
            '继续查找下一个匹配项
            Set fCell = .Find(what:="finished", LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
        Loop
        
        '调整目标表的表格区域以匹配新数据
        If lastRow <> 0 Then
            wsDest.ListObjects("Table2").Resize wsDest.Range("A4:AG" & lastRow)
        End If
    End With
    
    '恢复屏幕刷新
    Application.ScreenUpdating = True
    
End Sub

实现完整需求的改进代码 #

以下是满足全部自动处理需求的VBA代码：

Sub AutoSendStaffEmails()
    Dim wbAllData As Workbook
    Dim wsContents As Worksheet
    Dim wsStaffEmail As Worksheet
    Dim wsTemp As Worksheet
    Dim lastRowStaff As Long, lastRowContents As Long, lastRowTemp As Long
    Dim i As Long, matchRow As Long
    Dim staffName As String, staffEmail As String
    Dim sentList As String
    Dim outlookApp As Object, outlookMail As Object
    Dim tempFilePath As String
    
    '设置文件路径（请根据实际路径修改）
    Const ALL_DATA_PATH As String = "C:\YourPath\All Data.xlsx" '替换为实际的All Data工作簿路径
    tempFilePath = Environ("TEMP") & "\Immediate Action Needed.xlsx" '临时文件路径
    
    '初始化Outlook对象
    Set outlookApp = CreateObject("Outlook.Application")
    
    '获取当前工作簿的Staff email工作表
    Set wsStaffEmail = ThisWorkbook.Worksheets("Staff email")
    '打开All Data工作簿
    Set wbAllData = Workbooks.Open(ALL_DATA_PATH, ReadOnly:=True)
    Set wsContents = wbAllData.Worksheets("Contents")
    
    '关闭屏幕刷新
    Application.ScreenUpdating = False
    
    '获取Staff email表的最后一行
    lastRowStaff = wsStaffEmail.Cells(wsStaffEmail.Rows.Count, "A").End(xlUp).Row
    
    '遍历每位人员
    For i = 2 To lastRowStaff
        staffName = wsStaffEmail.Cells(i, "A").Value
        staffEmail = wsStaffEmail.Cells(i, "B").Value
        
        '检查邮箱是否有效
        If staffEmail = "" Then GoTo NextStaff
        
        '创建临时工作表存储提取的数据
        On Error Resume Next
        Set wsTemp = ThisWorkbook.Worksheets("TempData")
        If Err.Number <> 0 Then
            Set wsTemp = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
            wsTemp.Name = "TempData"
        End If
        On Error GoTo 0
        '清空临时表数据
        wsTemp.Cells.Clear
        
        '复制Contents表的表头到临时表
        wsContents.Rows(1).Copy wsTemp.Rows(1)
        lastRowTemp = 1
        
        '在Contents表中查找该人员的所有行
        lastRowContents = wsContents.Cells(wsContents.Rows.Count, "B").End(xlUp).Row
        For matchRow = 2 To lastRowContents
            If wsContents.Cells(matchRow, "B").Value = staffName Then
                lastRowTemp = lastRowTemp + 1
                '复制指定列：A:O和AF:AG（可根据需求调整）
                wsContents.Cells(matchRow, "A").Resize(1, 15).Copy
                wsTemp.Cells(lastRowTemp, "A").PasteSpecial Paste:=xlPasteValues
                wsContents.Cells(matchRow, "AF").Resize(1, 2).Copy
                wsTemp.Cells(lastRowTemp, "P").PasteSpecial Paste:=xlPasteValues
            End If
        Next matchRow
        
        '如果找到数据则发送邮件
        If lastRowTemp > 1 Then
            '保存临时表为单独的Excel文件
            wsTemp.Copy
            ActiveWorkbook.SaveAs Filename:=tempFilePath, FileFormat:=xlOpenXMLWorkbook
            ActiveWorkbook.Close SaveChanges:=False
            
            '创建邮件
            Set outlookMail = outlookApp.CreateItem(0)
            With outlookMail
                .To = staffEmail
                .Subject = "Immediate Action Required"
                .Body = "Hi " & staffName & "," & vbNewLine & vbNewLine & _
                        "Please find your assigned tasks attached." & vbNewLine & vbNewLine & _
                        "Best regards,"
                .Attachments.Add tempFilePath
                .Send '直接发送，若需先显示邮件可改为.Display
            End With
            
            '记录已发送人员
            sentList = sentList & staffName & vbNewLine
        End If
        
        '删除临时表
        Application.DisplayAlerts = False
        wsTemp.Delete
        Application.DisplayAlerts = True
        
NextStaff:
    Next i
    
    '关闭All Data工作簿
    wbAllData.Close SaveChanges:=False
    
    '恢复屏幕刷新
    Application.ScreenUpdating = True
    
    '显示已发送名单
    If sentList <> "" Then
        MsgBox "已成功发送邮件给以下人员：" & vbNewLine & vbNewLine & sentList, vbInformation, "发送完成"
    Else
        MsgBox "未找到任何需要发送邮件的人员数据", vbInformation, "发送完成"
    End If
    
    '清理对象
    Set outlookMail = Nothing
    Set outlookApp = Nothing
    Set wsTemp = Nothing
    Set wsContents = Nothing
    Set wbAllData = Nothing
    Set wsStaffEmail = Nothing
    
    '删除临时文件
    Kill tempFilePath
End Sub

代码关键说明 #

1. 外部工作簿处理：通过指定路径打开「All Data」工作簿，设置为只读避免锁定原文件
2. 数据提取逻辑：遍历「Contents」表的所有行，匹配姓名后复制指定列数据到临时表，保留原数据不删除（如需删除可自行添加）
3. 临时附件生成：将临时表单独保存为Excel文件，发送后自动删除临时文件
4. Outlook集成：创建Outlook对象生成邮件，支持直接发送或显示邮件（修改.Send为.Display即可）
5. 异常处理：跳过无邮箱的人员，处理临时表创建的异常情况

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