VBA自动邮件优化需求：合并重复ID后批量发送邮件

嘿，我懂你现在的痛点——原来的VBA代码是每个ID单独发一封邮件，效率太低了对吧？现在要先把重复的Service Tag（也就是重复ID）合并，再给每个唯一ID发一封汇总邮件。结合你给出的代码片段，我给你整理了修改思路和具体代码：

第一步：先收集所有符合条件的唯一Service Tag #

我们可以用Scripting.Dictionary来存储唯一ID，因为字典的键天然具备唯一性，还能把同一个ID对应的所有行数据存到集合里，方便后续汇总：

Dim uniqueIDs As Object
Set uniqueIDs = CreateObject("Scripting.Dictionary")
Dim lRow As Long
lRow = OOW.Sheets("WORKING FILE").Cells(Rows.Count, "B").End(xlUp).Row

' 先遍历一次表格，筛选符合条件的行并收集唯一Service Tag
For i = 2 To lRow
    If OOW.Sheets("WORKING FILE").Range("W" & i) = "YES" And _
       OOW.Sheets("WORKING FILE").Range("B" & i) = "Ruz" And _
       OOW.Sheets("WORKING FILE").Range("Y" & i) = "" Then
        ' 替换成你实际存储Service Tag的列，比如C列就写"c" & i
        Dim serviceTag As String
        serviceTag = OOW.Sheets("WORKING FILE").Range("这里填Service Tag列位" & i).Value
        
        ' 若该ID未在字典中，就新建一个集合来存对应行数据
        If Not uniqueIDs.Exists(serviceTag) Then
            Set uniqueIDs(serviceTag) = New Collection
        End If
        ' 将当前符合条件的行加入对应ID的集合
        uniqueIDs(serviceTag).Add OOW.Sheets("WORKING FILE").Rows(i)
    End If
Next i

第二步：遍历每个唯一ID，汇总数据并发送邮件 #

现在字典里已经存好了所有唯一ID和对应的行数据，接下来就可以逐个ID汇总内容，再执行邮件发送：

' 遍历字典中的每个唯一Service Tag
Dim key As Variant
For Each key In uniqueIDs.Keys
    Dim targetRows As Collection
    Set targetRows = uniqueIDs(key)
    Dim mergedRng As Range
    Dim singleRow As Variant
    
    ' 把同一个ID的所有行合并成一个范围，方便插入邮件
    Set mergedRng = targetRows(1)
    For Each singleRow In targetRows
        Set mergedRng = Union(mergedRng, singleRow)
    Next singleRow
    
    ' 这里插入你原来的邮件发送逻辑
    ' 比如设置邮件标题、收件人，把mergedRng的内容插入邮件等
    ' 示例（替换成你自己的邮件代码）：
    ' Set OutApp = CreateObject("Outlook.Application")
    ' Set OutMail = OutApp.CreateItem(0)
    ' With OutMail
    '     .To = "收件人邮箱"
    '     .Subject = "汇总邮件：Service Tag - " & key
    '     .HTMLBody = "<p>以下是该Service Tag的相关内容：</p>" & mergedRng.HTML
    '     .Send
    ' End With
Next key

一些实用注意事项 #

• 替换列位：一定要把代码里的"这里填Service Tag列位"改成实际存储Service Tag的列（比如Service Tag在D列就写"D" & i）
• 精简数据：如果不需要整行数据，可以只收集关键列，比如把targetRows.Add OOW.Sheets("WORKING FILE").Rows(i)改成targetRows.Add OOW.Sheets("WORKING FILE").Range("A" & i & ":F" & i)，只取A到F列的内容
• 兼容性：代码里用的是CreateObject("Scripting.Dictionary")，不需要额外引用VBA库，直接就能运行

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