Excel 宏仅将电子邮件发送到第一个电子邮件地址，而不是全部答案

【问题标题】：Excel macro sends email only to first email address, not allExcel 宏仅将电子邮件发送到第一个电子邮件地址，而不是全部
【发布时间】：2022-09-25 00:03:11
【问题描述】：

我是宏方面的新手，但我在 Excel 中创建了一个宏，我想循环浏览我的电子表格并在特定单元格值为空时发送电子邮件。此代码用于发送第一封电子邮件，但所有剩余的电子邮件仅显示第一封电子邮件收件人和主题。它不会执行发送唯一的第二封电子邮件或任何其他电子邮件。

接下来我可以尝试什么？

下面是我正在使用的代码：

Sub Macro1()
Dim rngCell As Range
Dim rngMyDataSet As Range
Dim Rng As Range
Dim OutApp As Object
Dim objOutlook As Object
Dim OutMail As Object
Dim EmailSubject As String
Dim sTo As String
Dim MailBody As Range
Dim EmailRecipient As String
Dim Signature As String
Application.ScreenUpdating = False
With ActiveSheet
If .FilterMode Then .ShowAllData
Set Rng = .Range(\"AH5\", .Cells(.Rows.Count, 1).End(xlUp))
End With
For Each rngCell In Rng
If rngCell.Offset(0, 6) > 0 Then

ElseIf rngCell.Offset(0, 5) > Evaluate(\"Today() +7\") And _
rngCell.Offset(0, 5).Value <= Evaluate(\"Today() +120\") Then
rngCell.Offset(0, 6).Value = Date

Set OutApp = CreateObject(\"Outlook.Application\")
Set OutMail = OutApp.CreateItem(0)

strbody = \"According to my records, your \" & Range(\"A5\").Value & \" contract is due for review         \" & rngCell.Offset(0, 5).Value & _
\".  It is important you review this contract ASAP and email me with any changes made.  If it is renewed, please fill out the Contract Cover Sheet which can be found in the Everyone folder and send me the cover sheet along with the new original contract.\"
EmailSendTo = Sheets(\"sheet1\").Range(\"AH5\").Value
EmailSubject = Sheets(\"sheet1\").Range(\"A5\").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_Value = Mail_Recipient.Offset(i - 1).Value
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing

End If

Next rngCell
Application.ScreenUpdating = True
End Sub

EmailSendTo = Sheets(\"sheet1\").Range(\"AH5\").Value 总是一样的。
I\'ve created a macro为什么我不相信XD

标签： excel vba email outlook office-automation

【解决方案1】：

此代码用于发送第一封电子邮件，但所有剩余的电子邮件仅显示第一封电子邮件收件人和主题。

您的代码根据 Excel 工作表中的数据创建一个新的邮件项目。但它不会自动发送任何电子邮件。相反，代码显示一个新创建的项目。要发送邮件，您需要调用Send 方法而不是Display，如下代码所示：
With OutMail
.To = EmailSendTo
.CC = "hhh@gmail.com"
.BCC = ""
.Subject = EmailSubject
.Body = strbody
.Send

【讨论】：

【解决方案2】：

创建邮件时更改行。

看起来范围比你想象的要大。用 A 列替换 A 列可能就足够了。

Option Explicit

Sub Macro1()

' Starting in row 5
' Contract ID in column A
' Date in column F
' Zero or positive integer in column G
' Recipient in column AH

Dim rngCell As Range
Dim Rng As Range

Dim OutApp As Object
Dim OutMail As Object

Dim EmailSendTo As String
Dim EmailSubject As String

'Application.ScreenUpdating = False

With ActiveSheet
    If .FilterMode Then .ShowAllData
    
    'Set Rng = .Range("AH5", .Cells(.Rows.Count, 1).End(xlUp))
    'Debug.Print "Rng.Cells.Count: " & Rng.Cells.Count
    ' To see Rng
    'Rng.Select
    
    ' Assumes the number of rows in column A is the same as in column AH
    Set Rng = .Range("A5", .Cells(.Rows.Count, 1).End(xlUp))
    Debug.Print "Rng.Cells.Count: " & Rng.Cells.Count
    ' To see Rng
    'Rng.Select
End With

' Outside of the For loop
Set OutApp = CreateObject("Outlook.Application")

For Each rngCell In Rng

    Debug.Print
    Debug.Print "rngCell.Row.........: " & rngCell.Row
    Debug.Print "       rngCell.Offset(0, 6): " & rngCell.Offset(0, 6)
    
    If rngCell.Offset(0, 6) > 0 Then
        Debug.Print
        Debug.Print "       rngCell.Offset(0, 6) > 0 = Do nothing."
    
    Else
        Debug.Print
        Debug.Print "       rngCell.Offset(0, 5): " & rngCell.Offset(0, 5)
        Debug.Print "                  Today + 7: " & Evaluate("Today() +7")
        Debug.Print " CDbl(rngCell.Offset(0, 5)): " & CDbl(rngCell.Offset(0, 5))
        Debug.Print "                Today + 120: " & Evaluate("Today() +120")
        
        If rngCell.Offset(0, 5) > Evaluate("Today() +7") And _
          rngCell.Offset(0, 5).Value <= Evaluate("Today() +120") Then
    
            Debug.Print "       rngCell.Offset(0, 5): " & rngCell.Offset(0, 5) & " = Action"
            
            Set OutMail = OutApp.CreateItem(0)
            
            Dim strbody As String
            strbody = "According to my records, your " & Range("A" & rngCell.Row).Value & " contract is due for review         " & rngCell.Offset(0, 5).Value & _
            ".  It is important you review this contract ASAP and email me with any changes made.  If it is renewed, please fill out the Contract Cover Sheet which can be found in the Everyone folder and send me the cover sheet along with the new original contract."
                       
            EmailSendTo = Sheets("sheet1").Range("AH" & rngCell.Row).Value
            EmailSubject = Sheets("sheet1").Range("A" & rngCell.Row).Value
            
            With OutMail
                .To = EmailSendTo
                .CC = "hhh@gmail.com"
                .BCC = ""
                .Subject = EmailSubject
                .Body = strbody
                .Display
            End With
            
            Set OutMail = Nothing
                        
        Else
            Debug.Print
            Debug.Print "       rngCell.Offset(0, 5): " & rngCell.Offset(0, 5) & " = Do nothing."
            
        End If
        
    End If

Next rngCell

Set OutApp = Nothing

Application.ScreenUpdating = True
Debug.Print "Done."

End Sub

始终删除On Error Resume Next 后跟用于创建邮件项的代码。它应该是 99.99999% 的正确操作。

【讨论】：