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
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