Listbox option to send to all or specified recipients

Question

I looked through a few posts but it didn't help.

My code merges same emails into one email and also consolidates a table. Works if I were to send to all.

Sub SendEmail()
    OptimizedMode True
    
    Dim OutApp As Object
    Dim OutMail As Object
    Dim dict As Object 'keep the unique list of emails
    Dim cell As Range
    Dim cell2 As Range
    Dim Rng As Range
    Dim i As Long
    Dim ws As Worksheet
    Dim Signature As String
    
    Set OutApp = CreateObject("Outlook.Application")
    Set dict = CreateObject("scripting.dictionary")
    Set ws = ThisWorkbook.Sheets("Table") 'Current worksheet name
    
    On Error GoTo cleanup
    For Each cell In ws.Columns("A").Cells.SpecialCells(xlCellTypeConstants)
        If cell.Value Like "?*@?*.?*" Then
    
            'check if this email address has been used to generate an outlook email or not
            If dict.exists(cell.Value) = False Then
    
                dict.Add cell.Value, "" 'add the new email address
                Set OutMail = OutApp.CreateItem(0)
                Set Rng = ws.UsedRange.Rows(1)
    
                'find all of the rows with the same email and add it to the range
                For Each cell2 In ws.UsedRange.Columns(1).Cells
                    If cell2.Value = cell.Value Then
                        Set Rng = Application.Union(Rng, ws.UsedRange.Rows(cell2.Row))
                    End If
                        
                    With ws.UsedRange
                        Set Rng = Intersect(Rng, .Columns(2).Resize(, .Columns.Count - 1))
                    End With
                Next cell2
    
                On Error Resume Next
                With OutMail
                    .SentOnBehalfOfName = "email@email"
                    .GetInspector ' ## This inserts default signature
                    Signature = .HTMLBody ' ## Capture the signature HTML
                    .To = cell.Value
                    .CC = "[email protected]"
                    .Subject = "Reminder"
                    .HTMLBody = "test"
                        
                    If UserForm1.OptionButton1.Value = True Then
                        .Send
                    Else
                        .Display
                    End If
                End With
                On Error GoTo 0
                
                Set OutMail = Nothing
            End If
        End If
    Next cell
    
cleanup:
    Set OutApp = Nothing
    AppActivate UserForm1.Caption
    Dim OutPut As Integer
    OutPut = MsgBox("Successfully Completed Task.", vbInformation, "Completed")
        
    OptimizedMode False
End Sub

I want an option for "send all" or "send to selected" on the listbox.

Also how would I exit sub if it detects either blanks or "Not Found"?

Private Sub CommandButton3_Click()
    If ButtonOneClick Then
         GoTo continue
    Else
        MsgBox "Please Generate Table.", vbCritical
        Exit Sub
    End If
    ButtonOneClick = False
    
continue:
    Dim Wb As Workbook
    Dim ws As Worksheet
    Dim rng1 As Range
    Set Wb = ThisWorkbook
    Set ws = Wb.Sheets("Table")
    'find not found or any blanks...
    Set rng1 = ws.Range("A:A").Find("Not Found", ws.[a1], xlValues, xlWhole, , xlNext)
    If Not rng1 Is Nothing Then
        MsgBox "ERROR. Check E-mails in Table.", vbCritical
    Else
        Call SendEmail
        CommandButton3.Enabled = False
    End If
End Sub

How can I incorporate something like this?

For i = 0 To Me.ListBox1.ListCount - 1
    With Me.ListBox1
        If Me.opt_All.Value = True Then
            Call SendEmail
        Else
            If .Selected(i) Then
                call SendEmail
            End If
        End If
    End With
Next i

Answer 1

Separate your script into 3 parts. First build the mailing list. Then for each address determine the range and send the email.

Replce you code after continue: with MEmail.CreateMailList and add a module called MEmail with this code

Option Explicit

Sub CreateMailList()

    Dim MailList
    Set MailList = CreateObject("Scripting.Dictionary")

    ' build email list
    Dim i As Integer, rng As Range, addr
    With UserForm1.ListBox1

        ' scan table building ranges
        For i = 0 To .ListCount - 1
            If .Selected(i) Or UserForm1.OptionButton3.Value = True Then
                
                addr = Trim(.List(i, 0)) ' email address
                If Len(addr) > 0 Then
                    If Not MailList.exists(addr) Then
                        Set rng = Sheets("Table").Cells(1, 2).Resize(1, .ColumnCount-1)
                        MailList.Add addr, rng
                    End If

                    Set rng = Sheets("Table").Cells(i + 2, 2).Resize(1, .ColumnCount-1)
                    Set MailList(addr) = Union(MailList(addr), rng)
                End If

            End If
        Next i
    End With

    If MailList.Count = 0 Then
        MsgBox "No rows selected", vbExclamation
    Else
        If MsgBox("Do you want to send " & MailList.Count & " emails", vbYesNo) = vbYes Then
            SendEmails MailList
        End If
    End If

End Sub

Sub SendEmails(ByRef MailList)
    'OptimizedMode True
    
    Dim OutApp, addr
    
    ' send email
    Set OutApp = CreateObject("Outlook.Application")
    For Each addr In MailList
        SendOneEmail OutApp, CStr(addr), MailList.item(addr)
    Next
     
    Set OutApp = Nothing
    'AppActivate UserForm1.Caption
    MsgBox "Successfully Completed", vbInformation, "Completed Emails Sent=" & MailList.Count
        
    'OptimizedMode False
End Sub

Sub SendOneEmail(OutApp, EmailAddress As String, rng As Range)

    Dim OutMail, Signature As String
    Set OutMail = OutApp.CreateItem(0)

    ' email
    With OutMail
        .SentOnBehalfOfName = "email@email"
        .GetInspector ' ## This inserts default signature
        Signature = .HTMLBody ' ## Capture the signature HTML
        .To = EmailAddress
        .CC = "[email protected]"
        .Subject = "Reminder"
        .HTMLBody = "<BODY style=font-size:12pt;font-family:Calibri><font color=#000000>Hi " _
                   & WorksheetFunction.Proper(RemoveNumbers(Left((EmailAddress), InStr((EmailAddress), ".") - 1))) & ", " & _
                    "<br><br>" & "Please see your trip numbers and estimated cost below:" & _
                   vbNewLine & vbNewLine & RangetoHTML(rng) & Signature & "</font></BODY>"

        If UserForm1.OptionButton1.Value = True Then
           ' .Send
        Else
            .Display
        End If
    End With
    Set OutMail = Nothing
    
End Sub