Excel宏仅向首个收件人发送邮件，无法批量发送求助

你的代码只能发送第一封正确邮件，后续邮件都复用第一行的收件人和主题，核心原因是固定引用了A5、AH5单元格，没有随着遍历的每一行动态获取对应行的内容。

关键修改点： #

• 替换固定的Range("A5")和Sheets("sheet1").Range("AH5")，通过rngCell.Row获取当前遍历行的行号，动态匹配对应单元格值
• 将Outlook应用对象的创建移到循环外部，避免重复创建浪费资源
• 清理代码中未定义的无效变量（如Mail_Recipient、i）

修改后的完整代码： #

Sub Macro1()
    Dim rngCell As Range
    Dim Rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody As String
    Dim EmailSendTo As String
    Dim EmailSubject As String
    Dim Signature As String
    
    Application.ScreenUpdating = False
    
    ' 仅初始化一次Outlook对象，提升效率
    Set OutApp = CreateObject("Outlook.Application")
    
    With ActiveSheet
        If .FilterMode Then .ShowAllData
        ' 修正数据范围：从AH5列开始，取到该列最后一行有数据的单元格
        Set Rng = .Range("AH5", .Cells(.Rows.Count, "AH").End(xlUp))
    End With
    
    For Each rngCell In Rng
        ' 简化条件判断逻辑
        If (rngCell.Offset(0, 6).Value <= 0 Or rngCell.Offset(0, 6).Value = "") And _
           rngCell.Offset(0, 5).Value > Date + 7 And _
           rngCell.Offset(0, 5).Value <= Date + 120 Then
           
            rngCell.Offset(0, 6).Value = Date
            
            Set OutMail = OutApp.CreateItem(0)
            
            ' 动态获取当前行的合同名称（A列）和收件人（AH列）
            strbody = "根据记录，你的 " & ActiveSheet.Cells(rngCell.Row, "A").Value & _
                      " 合同将于 " & rngCell.Offset(0, 5).Value & _
                      " 到期审核。请尽快审核并邮件告知任何修改。如果续约，请填写Everyone文件夹中的合同封面表，将封面表和新的原始合同一起发送给我。"
            EmailSendTo = ActiveSheet.Cells(rngCell.Row, "AH").Value
            EmailSubject = ActiveSheet.Cells(rngCell.Row, "A").Value & " 合同审核提醒"
            
            ' 保留原签名路径逻辑
            Signature = "C:\Documents and Settings\" & Environ("rmm") & _
                        "\Application Data\Microsoft\Signatures\rm.htm"
            
            On Error Resume Next
            With OutMail
                .To = EmailSendTo
                .CC = "hhh@gmail.com"
                .BCC = ""
                .Subject = EmailSubject
                .Body = strbody
                .Display ' 若需自动发送，替换为.Send
            End With
            On Error GoTo 0
            
            Set OutMail = Nothing
        End If
    Next rngCell
    
    Set OutApp = Nothing
    Application.ScreenUpdating = True
End Sub

额外说明： #

• 原代码中Evaluate("Today() +7")可直接用Date +7，更简洁高效
• 若要自动发送邮件，将.Display改为.Send即可
• 原代码中Send_Value = Mail_Recipient.Offset(i - 1).Value为无效代码，已删除

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