我对宏很熟悉，但我在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 DataMicrosoftSignaturesrm.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
此代码用于发送第一封电子邮件，但所有剩余的电子邮件只显示第一封电子邮件的收件人和主题。
您的代码基于Excel工作表中的数据创建新的邮件项目。但它不会自动发送任何电子邮件。相反，代码显示一个新创建的项。要发送邮件，您需要调用Send方法而不是Display，如下代码所示：
With OutMail
.To = EmailSendTo
.CC = "hhh@gmail.com"
.BCC = ""
.Subject = EmailSubject
.Body = strbody
.Send
创建邮件时更改行。
看起来范围比你想象的要大。用A列代替AH列可能就足够了。
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%的时间应该是正确的操作。