我的工作表"Volglijst"包含一个列表，其中包含已注册发送的所有包。当供应商或快递员提取包裹时，收货服务会登记日期和提取包裹的人。
当他们关闭文件时，会出现一个弹出窗口，询问他们是否要向请求发送的人发送电子邮件确认。当他们选择"是"时，VBA应检查工作表"Volglijst"中的所有行，其中B列和Q列中有日期，S列为空(这三个条件应同时适用，如果不适用，则不需要发送电子邮件(。
我正在启动outlook并创建一封新的电子邮件，但它仍然是空的。正文正在为其他电子邮件工作——只有对单元格内容的引用被调整为与条件适用的行相匹配。
Dim OutApp As Object
Dim OutMail As Object
Dim i As Long
Dim t As Range
Dim WkSht As Worksheet
Dim strbody As String
Set WkSht = Sheets("Volglijst")
For i = 1 To 999
If WkSht.Cells(i, 2).Value <> "" And WkSht.Cells(i, 17).Value <> "" And WkSht.Cells(i, 19).Value = "" Then
Dim rng As Range
With Application.Intersect(WkSht.Rows(i), WkSht.UsedRange)
Set rng = WkSht.Range(WkSht.Cells(i, 3), .Cells(.Cells.Count))
End With
If rng Is Nothing Then
Exit Sub
End If
End If
Next
On Error Resume Next
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "<font size=""3"" face=""Calibri"">" & _
"Beste Collega,<br><br>" & _
"Uw pakket met nummer <B>" & WkSht.Cells(WkSht.Rows(i), 1).Value & "</B> werd <B>" & WkSht.Cells(WkSht.Rows(i), 17).Value & "</B> opgehaald door <B>" & WkSht.Cells(WkSht.Rows(i), 16).Value & "</B>.<br>" & _
"Bijkomende opmerkingen goederenontvangst: <B>" & WS.Cells(WkSht.Rows(i), 18).Value & "</B>.<br>" & _
"<br><br>In geval van vragen gelieve contact op te nemen." & _
"<br><br> Met vriendelijke groeten, </font>"
On Error Resume Next
With OutMail
.To = WS.Cells(WkSht.Rows(i), 5).Value
.CC = ""
.BCC = ""
.Subject = "Ophaling pakket " & WS.Cells(i, 1).Value & ""
.HTMLBody = strbody
.Display 'or use .Send
End With
对于列为B<>的每一行，都将发送一封单独的电子邮件"；列Q<>"，列S="，收件人是该行e列的电子邮件地址。电子邮件正文中的详细信息也应来自相应的行。
将尝试对此进行划分，但您有两个重大问题：
-
您在循环之外的这封电子邮件的outlook方面使用了
i，所以您只是在使用i = 999，还是打算在循环中使用？ -
你的
strbody中的参考是针对不同的工作表。。。检查你的推荐信。当我开始定义每次使用时，我调用了Excel_Activities子例程中的第一次出现。
Public bdy_a as string, bdy_b as string, bdy_c as string, bdy_d as string
Public to_ as string
Public sub_ as string
'
Sub Excel_Activities()
Dim i as Long, t As Range
Dim WkSht As Worksheet
Dim strbody As String
Set WkSht = Sheets("Volglijst")
For i = 1 To 999
If WkSht.Cells(i, 2).Value <> "" And WkSht.Cells(i, 17).Value <> "" And WkSht.Cells(i, 19).Value = "" Then
Dim rng As Range
With Application.Intersect(WkSht.Rows(i), WkSht.UsedRange)
Set rng = WkSht.Range(WkSht.Cells(i, 3), .Cells(.Cells.Count))
End With
If rng Is Nothing Then
Exit Sub
Else
bdy_a = WkSht.Cells(i, 1).Value
bdy_b = WkSht.Cells(i, 17).Value
bdy_c = WkSht.Cells(i, 16).Value
bdy_d = WS.Cells(i, 18).Value 'IS THIS CORRECT SHEET?
to_ = WS.Cells(WkSht.Rows(i), 5).Value
sub_ = WS.Cells(i, 1).Value
Application.Run("Outlook_Activities")
End If
End If
Next
End Sub
然后处理保存的值以创建所需的电子邮件，该电子邮件似乎出现在Loop中，基于您在原始帖子strbody中使用的i。
Private Sub Outlook_Activities()
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "<font size=""3"" face=""Calibri"">" & "Beste Collega,<br><br>" & "Uw pakket met nummer <B>" & bdy_a & "</B> werd <B>" & bdy_b & "</B> opgehaald door <B>" & bdy_c & "</B>.<br>" & "Bijkomende opmerkingen goederenontvangst: <B>" & & "</B>.<br>" & "<br><br>In geval van vragen gelieve contact op te nemen." & "<br><br> Met vriendelijke groeten, </font>"
With OutMail
.To = to_
.CC = ""
.BCC = ""
.Subject = "Ophaling pakket " & sub_ & ""
.HTMLBody = strbody
.Display 'or use .Send
End With
End Sub
我相信以下是您想要的，这将从UsedRange中的第1行循环到最后一行，检查列B&Q不为空，S列为空，然后按行处理电子邮件：
Sub LoopThroughRange_SendEmail()
Dim OutApp As Object: Set OutApp = CreateObject("Outlook.Application")
Dim OutMail As Object: Set OutMail = OutApp.CreateItem(0)
Dim i As Long
Dim strbody As String
Dim WkSht As Worksheet: Set WkSht = Sheets("Volglijst")
For i = 1 To WkSht.UsedRange.Rows.Count
If WkSht.Cells(i, "B").Value <> "" And WkSht.Cells(i, "Q").Value <> "" And WkSht.Cells(i, "S").Value = "" Then
strbody = "<html><body><font size=""3"" face=""Calibri"">Beste Collega,<br><br>Uw pakket met nummer <b>" & _
WkSht.Cells(i, "A").Value & "</b> werd <b>" & WkSht.Cells(i, "Q").Value & "</b> opgehaald door <b>" & _
WkSht.Cells(i, "P").Value & "</b>.<br>Bijkomende opmerkingen goederenontvangst: <b>" & _
WkSht.Cells(i, "R").Value & "</B>.<br><br><br>In geval van vragen gelieve contact op te nemen.<br><br>" & _
"Met vriendelijke groeten, </font></body></html>"
With OutMail
.To = WkSht.Cells(i, "E").Value
.CC = ""
.BCC = ""
.Subject = "Ophaling pakket " & WkSht.Cells(i, "A").Value & ""
.HTMLBody = strbody
.Display 'or use .Send
End With
End If
Next i
End Sub
更新：
为了在尝试发送电子邮件之前验证电子邮件地址，以下内容将有所帮助，它将允许多个电子邮件地址位于由a分隔的单个单元格中；
Sub LoopThroughRange_SendEmail()
Dim oRegEx As Object
Set oRegEx = CreateObject("VBScript.RegExp")
Dim OutApp As Object: Set OutApp = CreateObject("Outlook.Application")
Dim OutMail As Object: Set OutMail = OutApp.CreateItem(0)
Dim i As Long
Dim strbody As String
Dim WkSht As Worksheet: Set WkSht = Sheets("Volglijst")
For i = 1 To WkSht.UsedRange.Rows.Count
If ValidEmail(WkSht.Cells(i, "E").Value, oRegEx) Then
If WkSht.Cells(i, "B").Value <> "" And WkSht.Cells(i, "Q").Value <> "" And WkSht.Cells(i, "S").Value = "" Then
strbody = "<html><body><font size=""3"" face=""Calibri"">Beste Collega,<br><br>Uw pakket met nummer <b>" & _
WkSht.Cells(i, "A").Value & "</b> werd <b>" & WkSht.Cells(i, "Q").Value & "</b> opgehaald door <b>" & _
WkSht.Cells(i, "P").Value & "</b>.<br>Bijkomende opmerkingen goederenontvangst: <b>" & _
WkSht.Cells(i, "R").Value & "</B>.<br><br><br>In geval van vragen gelieve contact op te nemen.<br><br>" & _
"Met vriendelijke groeten, </font></body></html>"
With OutMail
.To = WkSht.Cells(i, "E").Value
.CC = ""
.BCC = ""
.Subject = "Ophaling pakket " & WkSht.Cells(i, "A").Value & ""
.HTMLBody = strbody
.Display 'or use .Send
End With
End If
Else
'email address is not valid
End If
Next i
End Sub
Public Function ValidEmail(pAddress As String, ByRef oRegEx As Object) As Boolean
With oRegEx
.Pattern = "^(([a-zA-Z0-9_-.']+)@(([[0-9]{1,3}.[0-9]{1,3}.[0-9]{1,3}.)|(([a-zA-Z0-9-]+.)+))([a-zA-Z]{2,4}|[0-9]{1,3})(]?)(s*;s*|s*$))+$" 'pattern for multiple email addresses included
ValidEmail = .test(pAddress)
End With
End Function