I've looked through a few previous post but it didn't seem to help me.
My current send email:
merges same emails into 1 email and also consolidates a table for them too - works perfectly if I were to send to all
However, I want to have an option for send all or send to selected on the listbox. (also how would I be able to exit sub if it detects either blanks or "Not Found"
but I can't seem to incorporate something like this into it..
Would really appreciate any help.
My current send email:
merges same emails into 1 email and also consolidates a table for them too - works perfectly if I were to send to all
VBA Code:
'
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@test.com"
.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
However, I want to have an option for send all or send to selected on the listbox. (also how would I be able to exit sub if it detects either blanks or "Not Found"
VBA Code:
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
but I can't seem to incorporate something like this into it..
VBA Code:
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
Would really appreciate any help.