如何用VBA将Excel中变动超10%的记录添加至Outlook邮件？

核心需求实现 #

• 从「Weekly Changes」工作表中筛选E列变动幅度超过10%的记录
• 按「部门 - 财年 - 产品 变动百分比」的层级格式分组整理内容
• 生成符合示例排版的Outlook邮件正文

完整修改后的VBA代码 #

Sub SendWeeklyChangesEmail()
    Dim OutLookApp As Object
    Dim OutLookMailItem As Object
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim dept As String
    Dim fy As String
    Dim product As String
    Dim change As Double
    Dim emailBody As String
    Dim deptDict As Object ' 按部门分组存储数据
    Dim fyDict As Object   ' 按财年分组存储产品数据
    
    ' 初始化Outlook对象
    Set OutLookApp = CreateObject("Outlook.Application")
    Set OutLookMailItem = OutLookApp.CreateItem(0)
    
    ' 绑定目标工作表
    Set ws = ThisWorkbook.Worksheets("Weekly Changes")
    Set deptDict = CreateObject("Scripting.Dictionary")
    
    ' 获取数据最后一行（假设第一行为表头）
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    ' 遍历数据，筛选并分组
    For i = 2 To lastRow
        dept = ws.Cells(i, "A").Value ' 假设A列是部门
        fy = ws.Cells(i, "B").Value   ' 假设B列是财年(FY22/FY23)
        product = ws.Cells(i, "C").Value ' 假设C列是产品
        change = Abs(ws.Cells(i, "E").Value) ' 取E列变动幅度的绝对值
        
        ' 筛选条件：仅处理FY22/FY23且变动超过10%的记录
        If (fy = "FY22" Or fy = "FY23") And change > 0.1 Then
            changeStr = Format(change, "0%") ' 转换为百分比字符串
            
            ' 部门不存在则创建新的财年字典
            If Not deptDict.Exists(dept) Then
                Set fyDict = CreateObject("Scripting.Dictionary")
                deptDict(dept) = fyDict
            Else
                Set fyDict = deptDict(dept)
            End If
            
            ' 财年不存在则创建产品列表，否则追加产品信息
            If Not fyDict.Exists(fy) Then
                fyDict(fy) = product & " " & changeStr
            Else
                fyDict(fy) = fyDict(fy) & " - " & product & " " & changeStr
            End If
        End If
    Next i
    
    ' 构建邮件正文
    emailBody = "各位好：" _
              & "<br><br>" _
              & "每周变动情况：" _
              & "<br><br>"
    
    ' 遍历分组数据，生成正文内容
    For Each dept In deptDict.Keys
        Set fyDict = deptDict(dept)
        Dim firstFY As Boolean: firstFY = True
        
        For Each fy In fyDict.Keys
            If firstFY Then
                ' 首个财年显示部门名称
                emailBody = emailBody & dept & " - " & fy & " - " & fyDict(fy) & "<br>"
                firstFY = False
            Else
                ' 后续财年缩进对齐
                emailBody = emailBody & "          " & fy & " - " & fyDict(fy) & "<br>"
            End If
        Next fy
        emailBody = emailBody & "<br>" ' 部门间空行分隔
    Next dept
    
    ' 追加结尾
    emailBody = emailBody & "谢谢，" _
              & "<br><br>" _
              & "本人"
    
    ' 设置邮件属性
    With OutLookMailItem
        .To = "" ' 填写收件人邮箱
        .Subject = "每周变动情况"
        .HTMLBody = emailBody
        .Display ' 显示邮件，如需直接发送可改为.Send
    End With
    
    ' 释放对象
    Set OutLookMailItem = Nothing
    Set OutLookApp = Nothing
    Set deptDict = Nothing
    Set fyDict = Nothing
    Set ws = Nothing
End Sub

关键说明 #

• 列位置适配：代码默认A列=部门、B列=财年、C列=产品、E列=变动幅度（数值格式，如11%对应0.11），如果你的列位置不同，修改对应ws.Cells(i, "列标")即可
• 分组逻辑：通过双层字典实现「部门→财年→产品」的层级分组，确保同一部门的财年信息集中展示
• 格式匹配：用HTML标签<br>实现换行，通过空格实现缩进，完全匹配示例中的排版要求
• 筛选逻辑：仅处理FY22/FY23的记录，且变动幅度绝对值超过10%（数值>0.1）

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