当单元格值的组合为真时使用 VBA 发送电子邮件

Question

我的工作表“Volglijst”包含一个列表，其中包含已注册发送的所有包裹。 当供应商或快递员取件时，收货服务会记录取件日期和取件人。

当他们关闭文件时，会出现一个弹出窗口，询问他们是否要向请求发送的人发送电子邮件确认。 当他们选择是时，VBA 应检查工作表“Volglijst”中的所有行，其中 B 列和 Q 列中有日期，并且 S 列为空（这 3 个条件应同时适用，如果没有，则没有电子邮件需要发送）。

我正在让我的 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 ""; column Q "", Column S = "" ，并且收件人是该行中 E 列的电子邮件地址。电子邮件正文中的详细信息也应来自适用的行。

Answer 1

将尝试对此进行划分，但您有几个重大问题：

• 您在此电子邮件的 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

Answer 2

我相信您正在寻找以下内容，这将在 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

更新：

要在尝试发送电子邮件之前验证电子邮件地址，以下内容会有所帮助，它将允许单个单元格中的多个电子邮件地址由 ; 分隔

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