Excel合并单元格场景下按主题群发单封邮件的技术求助

首先得戳中问题根源：Excel合并单元格的主题只有首行存有效值，后续行的D列单元格实际是空的，所以你之前的代码逐行处理时，只能拿到首行的主题，后面的行主题直接缺失；再加上没做邮箱分组，自然会给每个邮箱单独发邮件。

下面给你分步骤的解决思路和可直接用的代码：

1. 先把合并单元格的主题填充到所有对应行 #

第一步要把D列合并单元格的主题同步到每一行，同时取消合并，这样每一行的邮箱和主题就能一一对应，方便后续分组：

Sub FillMergedSubjects()
    Dim targetSheet As Worksheet
    Set targetSheet = ActiveSheet
    
    Dim lastRow As Long
    lastRow = targetSheet.Cells(targetSheet.Rows.Count, "B").End(xlUp).Row
    
    Dim i As Long
    For i = 1 To lastRow
        If targetSheet.Cells(i, "D").MergeCells Then
            ' 将合并单元格的首行主题填充到整个合并区域
            targetSheet.Cells(i, "D").MergeArea.Value = targetSheet.Cells(i, "D").Value
            ' 取消合并，避免后续读取异常
            targetSheet.Cells(i, "D").MergeArea.UnMerge
        End If
    Next i
End Sub

2. 按主题分组邮箱，批量发送单封邮件 #

接下来用字典把相同主题的邮箱收集到一起，然后给每个主题对应的所有邮箱发一封邮件：

Sub SendGroupedEmails()
    Dim targetSheet As Worksheet
    Set targetSheet = ActiveSheet
    
    Dim lastRow As Long
    lastRow = targetSheet.Cells(targetSheet.Rows.Count, "B").End(xlUp).Row
    
    ' 用字典存储「主题-邮箱列表」的对应关系
    Dim emailGroupDict As Object
    Set emailGroupDict = CreateObject("Scripting.Dictionary")
    
    Dim i As Long
    For i = 2 To lastRow ' 假设第1行是表头，从第2行开始处理数据
        Dim currentSubject As String
        currentSubject = targetSheet.Cells(i, "D").Value
        Dim currentEmail As String
        currentEmail = targetSheet.Cells(i, "B").Value
        
        If emailGroupDict.Exists(currentSubject) Then
            ' 主题已存在，追加邮箱（用分号分隔，适配Outlook收件人格式）
            emailGroupDict(currentSubject) = emailGroupDict(currentSubject) & ";" & currentEmail
        Else
            ' 新主题，直接添加到字典
            emailGroupDict(currentSubject) = currentEmail
        End If
    Next i
    
    ' 调用Outlook发送分组邮件
    Dim outlookApp As Object
    Set outlookApp = CreateObject("Outlook.Application")
    
    Dim subjectKey As Variant
    For Each subjectKey In emailGroupDict.Keys
        Dim newMail As Object
        Set newMail = outlookApp.CreateItem(0)
        
        With newMail
            .To = emailGroupDict(subjectKey)
            .Subject = subjectKey
            .Body = "这里替换成你的邮件内容" ' 可根据需求修改格式或添加HTML内容
            .Display ' 测试阶段先预览，确认没问题后改成.Send直接发送
        End With
    Next subjectKey
    
    ' 清理对象
    Set outlookApp = Nothing
    Set newMail = Nothing
    MsgBox "邮件批量处理完成！"
End Sub

小提示 #

• 运行代码前确保Outlook已经打开，并且在Excel信任中心允许VBA访问Office应用
• 如果担心重复邮箱，可在添加到字典前加个判断，跳过已存在的邮箱地址

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