VBA向多个收件人发送电子邮件

Question

我需要以下代码的建议。当宏检查是否在＆＃34;客户端数据库＆＃34;提供了表单客户端基数，如果客户端按基本号码有不同的电子邮件并且呈现多次，请说三次，它只发送一封邮件。而不是一个客户的三个不同的电子邮件。任何想法如何解决它？

Sub SendMail()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim r As Range

    Set WS1 = ThisWorkbook.Worksheets("Incomes")
    Set WS2 = ThisWorkbook.Worksheets("Client database")
    Set ws3 = ThisWorkbook.Worksheets("Sheet3")

    iLastRow = WS1.Range("B1").End(xlDown).Row
    oLastRow = WS2.Range("B2").End(xlDown).Row




    Application.ScreenUpdating = False
        Set OutApp = CreateObject("Outlook.Application")
            OutApp.Session.Logon


    For Each r In Worksheets("Incomes").Columns("P").Cells.SpecialCells(xlCellTypeConstants)
    If r.Value Like "*no*" And r.Offset(0, 1).Value = "" Then

        match = r.Offset(0, -14).Value




       For Each cell In Worksheets("Client database").Columns("C").Cells.SpecialCells(xlCellTypeConstants)


       If cell = match Then
            nameList = cell.Offset(0, 17).Value
               On Error Resume Next
                 End If
                    Next cell


        'r.Offset(0, 1).Value = Date


             'r.Value = "Yes"


            Set OutMail = OutApp.CreateItem(0)

    On Error GoTo cleanup
    Set OutMail = OutApp.CreateItem(0)
    On Error Resume Next


    With OutMail
        .To = nameList
        .Subject = "Secure: Details for Incoming Payment"
        .Body = ws3.Range("A1").Value & r.Offset(0, -7).Value
        .Display 
    End With

    On Error GoTo 0
    Set OutMail = Nothing
    End If
    Next r

cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True
End Sub

实际上我有两个版本的这些代码，它们都在工作并追求一个目标。它是我尝试解决同样的任务。这些版本的问题是在＆＃34;客户端数据库＆＃34;在匹配的客户端编号下的工作表只有一封电子邮件，宏发出错误

  

＆＃34;运行时错误＆＃34; 13＆＃34;：类型不匹配＆＃34;

Sub SendMail()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim r As Range

    Set WS1 = ThisWorkbook.Worksheets("Incomes")
    Set WS2 = ThisWorkbook.Worksheets("Client database")
    Set ws3 = ThisWorkbook.Worksheets("Sheet3")

    iLastRow = WS1.Range("B1").End(xlDown).Row
    oLastRow = WS2.Range("B1").End(xlDown).Row




    Application.ScreenUpdating = False
        Set OutApp = CreateObject("Outlook.Application")
            OutApp.Session.Logon


    For Each r In Worksheets("Incomes").Columns("Q").Cells.SpecialCells(xlCellTypeConstants)
    If r.Value Like "*No*" Then

        match = r.Offset(0, -14).Value

     If WS2.AutoFilterMode = False Then
        WS2.Range("A1").AutoFilter
            WS2.AutoFilter.ShowAllData
            End If



    WS2.Range("C2:C" & oLastRow).AutoFilter Field:=3, Criteria1:=match

        nameList = Join(Application.Transpose(WS2.Range("T2:T" & oLastRow).SpecialCells(xlCellTypeVisible)), ";")



        'r.Offset(0, 1).Value = "Mail sent"

             'r.Value = "Yes"


            Set OutMail = OutApp.CreateItem(0)

    On Error GoTo cleanup
    Set OutMail = OutApp.CreateItem(0)
    On Error Resume Next


    With OutMail
        .To = nameList
        .Subject = "Secure: Details for Incoming Payment"
        .Body = ws3.Range("A1").Value & r.Offset(0, -7).Value
        .Display 
    End With

    On Error GoTo 0
    Set OutMail = Nothing
    End If
    Next r

cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True
End Sub

如果有人有兴趣，这是我当前的工作代码，它不会给一个收件人和一个收件人带来任何错误。

Sub SendMail()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim r As Range
    Dim receiverIsOne As Boolean
    Dim countEmails As Integer

    Set WS1 = ThisWorkbook.Worksheets("Incomes")
    Set WS2 = ThisWorkbook.Worksheets("Client database")
    Set ws3 = ThisWorkbook.Worksheets("Sheet3")

    iLastRow = WS1.Range("B1").End(xlDown).Row
    oLastRow = WS2.Range("B1").End(xlDown).Row


    Application.ScreenUpdating = False
        Set OutApp = CreateObject("Outlook.Application")
            OutApp.Session.Logon
            WS1.Range("A1").AutoFilter Field:=1, Criteria1:=Calendar.Value

    For Each r In Worksheets("Incomes").Columns("O").Cells.SpecialCells(xlCellTypeVisible)
    If r.Value Like "no" And r.Offset(0, 9).Value = "" Or r.Offset(0, 2).Value = "No" Then
        match = r.Offset(0, -13).Value
     If WS2.AutoFilterMode = False Then
        WS2.Range("A1").AutoFilter
            WS2.AutoFilter.ShowAllData
            End If


    WS2.Range("C2:C" & oLastRow).AutoFilter Field:=3, Criteria1:=match
        countEmails = WS2.Range("C2:C" & oLastRow).SpecialCells(xlCellTypeVisible).Cells.Count
        If (countEmails < 2) Then
            name1 = WS2.Range("C2:C" & oLastRow).Find(match, , , xlWhole).Offset(, 17).Value
            receiverIsOne = True


        End If
        If (countEmails > 1) Then
            receiverIsOne = False
            nameList = Join(Application.Transpose(WS2.Range("T2:T" & oLastRow).SpecialCells(xlCellTypeVisible)), ";")
            'MsgBox ("receiverIsOne = True, Count: " + countEmails)
        End If

             'r.Value = "Yes"


            Set OutMail = OutApp.CreateItem(0)

    On Error GoTo cleanup
    Set OutMail = OutApp.CreateItem(0)
    On Error Resume Next

        If (receiverIsOne) Then
            With OutMail
                .To = name1
                .Subject = "Secure -receiverIsOne " + match + "
                .Body = ws3.Range("A1").Value & r.Offset(0, -7).Value
                .Display 
            End With
        End If

        If (receiverIsOne = False) Then
            With OutMail
                .To = nameList
                .Subject = "(Secure) -receiversAreMany " + match + "
                .Body = ws3.Range("A1").Value & r.Offset(0, -7).Value
                .Display 
            End With
        End If

    On Error GoTo 0
    Set OutMail = Nothing
    End If
    Next r

cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True
End Sub

Answer 1

这个版本应该做你想要的。

Make a list on the ActiveSheet with :
In column A : Names of the people
In column B : E-mail addresses
In column C : yes or no ( if the value is yes it will create a mail)

宏将循环遍历活动表上的每一行，如果B列中有电子邮件地址，那么＆＃34;是＆＃34;在C栏中，它将为每个人创建一个带有下面提醒的邮件。如果列中有重复的地址，请查看此示例。

亲爱的Jelle（例如Jelle在A栏中的名字）

请与我们联系，讨论如何使您的帐户更新

Sub Test1()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Working in Office 2000-2016
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range

    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")

    On Error GoTo cleanup
    For Each cell In Columns("B").Cells.SpecialCells(xlCellTypeConstants)
        If cell.Value Like "?*@?*.?*" And _
           LCase(Cells(cell.Row, "C").Value) = "yes" Then

            Set OutMail = OutApp.CreateItem(0)
            On Error Resume Next
            With OutMail
                .To = cell.Value
                .Subject = "Reminder"
                .Body = "Dear " & Cells(cell.Row, "A").Value _
                      & vbNewLine & vbNewLine & _
                        "Please contact us to discuss bringing " & _
                        "your account up to date"
                'You can add files also like this
                '.Attachments.Add ("C:\test.txt")
                .Send  'Or use Display
            End With
            On Error GoTo 0
            Set OutMail = Nothing
        End If
    Next cell

cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True
End Sub

https://www.rondebruin.nl/win/s1/outlook/bmail5.htm

这是您需要考虑的另一个重要资源。

https://www.rondebruin.nl/win/s1/outlook/bmail7.htm

Answer 2

'连接多个细胞的内容

Function ConcatRange(inputRange As Range, Optional delimiter As String) As String
    Dim oneCell As Range
    With inputRange
        If Not (Application.Intersect(.Parent.UsedRange, .Cells) Is Nothing) Then
            For Each oneCell In Application.Intersect(.Parent.UsedRange, .Cells)
                If oneCell.Text <> vbNullString Then
                    ConcatRange = ConcatRange & delimiter & oneCell.Text
                End If
            Next oneCell
            ConcatRange = Mid(ConcatRange, Len(delimiter) + 1)
        End If
    End With
End Function

'向多个收件人发送电子邮件

Dim myDelegate As Outlook.Recipient

    For Each sTo In Recipient
        Set myDelegate = OutlookMailItem.Recipients.Add(sTo)
        myDelegate.Resolve
        If Not myDelegate.Resolved Then
            myDelegate.Delete
        End If
    Next sTo

    For Each sTo In CC
        Set myDelegate = OutlookMailItem.Recipients.Add(sTo)
        myDelegate.Type = olCC
        myDelegate.Resolve
        If Not myDelegate.Resolved Then
            myDelegate.Delete
        End If
    Next sTo