如何实现Excel工作簿打开时自动发送含符合条件行的邮件

需求背景 #

我有一个用于跟踪不同许可证过期日期的Excel电子表格：

• Sheet1包含1个表格
• Sheet2包含4个表格

目前已通过Workbook_Open事件结合shell:startup实现开机自动打开工作簿，并自动发送带附件的Outlook邮件，现有VBA代码如下：

Private Sub Workbook_Open()

    Dim emailApplication As Object
    Dim emailItem As Object

    Set emailApplication = CreateObject("Outlook.Application")
    Set emailItem = emailApplication.CreateItem(0)

    emailItem.to = "fake.email@emailaddress.com"
    emailItem.Subject = "Please Review; Upcoming Expiration Dates"
    emailItem.Body = "Please review the attached spreadsheet as it may have dates that are expired/soon to be expired. Please note there are multiple sheets."

    emailItem.Attachments.Add ActiveWorkbook.FullName
    emailItem.Display

    MsgBox "Your email has been sent.", vbInformation

End Sub

现在需要修改为：将G列值为“EXPIRED”或“Expires w/in 30 days”的对应行（如G2符合时提取B2:G2整行）以表格形式粘贴到邮件正文中。

已尝试过的方法：

• 复制修改Ron de Bruin及论坛代码，仅能将单个表格转为图片插入邮件，无法处理多工作表的多个表格
• 试过返回TRUE/FALSE、1/-1的代码，以及将表格内容转为段落形式的代码

已知变通方案：

• 将多工作表中符合条件的行复制到临时工作表，再将该工作表内容插入邮件正文
• 为每个工作表生成表格图片，分开发送邮件

解决方案代码 #

下面是实现需求的完整VBA代码，采用临时工作表汇总符合条件行的方案，确保邮件正文呈现规范的表格：

Private Sub Workbook_Open()
    Dim olApp As Object, olMail As Object
    Dim ws As Worksheet, tempWs As Worksheet
    Dim lastRow As Long, i As Long, tempRow As Long
    Dim criteria As Variant
    
    ' 初始化Outlook对象
    Set olApp = CreateObject("Outlook.Application")
    Set olMail = olApp.CreateItem(0)
    
    ' 创建临时工作表
    On Error Resume Next
    Set tempWs = ThisWorkbook.Worksheets("TempExpiry")
    If Err.Number <> 0 Then
        Set tempWs = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
        tempWs.Name = "TempExpiry"
    End If
    On Error GoTo 0
    tempWs.Cells.Clear ' 清空临时表内容
    
    ' 设置筛选条件
    criteria = Array("EXPIRED", "Expires w/in 30 days")
    
    ' 遍历所有工作表
    For Each ws In ThisWorkbook.Worksheets
        lastRow = ws.Cells(ws.Rows.Count, "G").End(xlUp).Row
        ' 跳过表头，从第2行开始检查
        For i = 2 To lastRow
            ' 判断G列是否符合条件
            If IsError(Application.Match(ws.Cells(i, "G").Value, criteria, 0)) = False Then
                tempRow = tempWs.Cells(tempWs.Rows.Count, "B").End(xlUp).Row
                If tempRow = 1 Then tempRow = 0 ' 首次复制时从第1行开始
                ' 复制符合条件的B到G列内容到临时表
                ws.Range("B" & i & ":G" & i).Copy Destination:=tempWs.Range("B" & tempRow + 1)
                ' 可选：在A列标注来源工作表
                tempWs.Cells(tempRow + 1, "A").Value = "来源：" & ws.Name
            End If
        Next i
    Next ws
    
    ' 处理邮件内容
    With olMail
        .To = "fake.email@emailaddress.com"
        .Subject = "Please Review; Upcoming Expiration Dates"
        .Attachments.Add ThisWorkbook.FullName
        
        ' 先添加正文说明
        .HTMLBody = "<p>请查看以下即将过期或已过期的许可证信息，完整表格见附件：</p>"
        
        ' 如果临时表有数据，插入表格
        If tempWs.Cells(tempWs.Rows.Count, "B").End(xlUp).Row > 1 Then
            ' 复制临时表的表头和数据区域
            tempWs.Range("A1:G" & tempWs.Cells(tempWs.Rows.Count, "B").End(xlUp).Row).Copy
            ' 切换到邮件的HTML编辑器并粘贴为表格
            .Display
            SendKeys "^v", True ' 粘贴内容
            ' 等待粘贴完成
            Application.Wait Now + TimeValue("00:00:01")
        Else
            .HTMLBody = .HTMLBody & "<p>当前无即将过期或已过期的许可证信息。</p>"
        End If
    End With
    
    ' 删除临时工作表（可选，若需要保留可注释此行）
    Application.DisplayAlerts = False
    tempWs.Delete
    Application.DisplayAlerts = True
    
    MsgBox "邮件已生成，请检查后发送。", vbInformation
    
    ' 释放对象
    Set olMail = Nothing
    Set olApp = Nothing
    Set tempWs = Nothing
    Set ws = Nothing
End Sub

代码说明 #

1. 临时工作表处理：创建临时表汇总所有工作表中符合条件的行，同时标注来源工作表方便追踪
2. 条件筛选：使用Application.Match判断G列值是否属于目标条件
3. 邮件正文构建：先添加说明文字，再将临时表内容粘贴为HTML表格，保证格式规范
4. 清理操作：自动删除临时工作表，避免文件冗余

注意事项 #

• 确保Excel启用了宏功能，且Outlook已正确配置
• 首次运行可能需要授权宏访问Outlook
• 若不需要标注来源工作表，可删除代码中关于A列赋值的行

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