I can't seem to get my code for automatic emails to work. The place I keep getting stuck on, is the first look for each unique value in column A.
Basically, I have a worksheet where e.g., one dashboard titled "Dashboard X" needs to be sent to multiple email addresses in ONE email. I found so much code online for multiple separate emails, but this all needs to be one big email per unique dashboard. Can anyone give me some advice on how to fix this loop?
Private Sub CommandButton1_Click()
On Error GoTo ErrHandler
' Set Outlook object.
Dim objOutlook As Object
Set objOutlook = CreateObject("Outlook.Application")
' Create email object.
Dim objEmail As Object
Set objEmail = objOutlook.CreateItem(olMailItem)
Dim UItem As Collection
Dim UV As New Collection
Dim rng As Range
Dim i As Long
Dim cell As Range
Dim iCnt As Integer ' Its just a counter.
Dim sMail_ids As String ' To store recipients email ids.
Dim myDataRng As Range
' We'll now set a range.
Set myDataRng = Range("B2", Range("B" & Rows.Count).End(xlUp))
Set rng = Range("A2", Range("A" & Rows.Count).End(xlUp))
'unique value loop
Set UItem = New Collection
On Error Resume Next
For Each rng In rng
UItem.Add CStr(rng), CStr(rng)
Next
On Error GoTo 0
For i = 1 To UItem.Count
Range("D" & i + 1) = UItem(i)
Next
' loop for emails
For Each cell In myDataRng
If Trim(sMail_ids) = "" Then
sMail_ids = cell.Offset(1, 0).Value
Else
sMail_ids = sMail_ids & vbCrLf & ";" & cell.Offset(1, 0).Value
End If
Next cell
Set rng = Nothing
Set myDataRng = Nothing ' Clear the range.
With objEmail
.To = sMail_ids ' Assign all email ids to the property.
.Subject = "This is a test message"
.Body = "Hi, there. Hope you are doing well."
.Display ' Display outlook message window.
End With
' Clear all objects.
Set objEmail = Nothing: Set objOutlook = Nothing
ErrHandler:
End Sub
There shouldn't be any line breaks in the email address and I would trim the values.
sMail_ids = sMail_ids & vbCrLf & ";" & cell.Offset(1, 0).Value
to
sMail_ids = sMail_ids & ";" & Trim(cell.Offset(1, 0).Value)
Here is how I would write it (note change the worksheet reference in DashboardRange()) :
Private Sub CommandButton1_Click()
Dim Addresses As String
Addresses = DashboardEmailList
If DashboardEmailList = "" Then Exit Sub
Const olMailItem = 0
' Set Outlook object.
Dim objOutlook As Object
Set objOutlook = CreateObject("Outlook.Application")
' Create email object.
Dim objEmail As Object
Set objEmail = objOutlook.CreateItem(olMailItem)
With objEmail
.To = Addresses ' Assign all email ids to the property.
.Subject = "This is a test message"
.Body = "Hi, there. Hope you are doing well."
.Display ' Display outlook message window.
End With
' Clear all objects.
Set objEmail = Nothing: Set objOutlook = Nothing
ErrHandler:
End Sub
Function DashboardRange() As Range
Set DashboardRange = Sheet1.Range("A1").CurrentRegion
End Function
Function DashboardEmailList() As String
If DashboardRange.Rows.Count = 1 Then Exit Function
Dim Data As Variant
Data = DashboardRange.Value
Dim Collection As New Collection
Dim Addresses As String
Dim r As Long
For r = 2 To UBound(Data)
If Trim(Data(r, 1)) <> "" And Trim(Data(r, 2)) <> "" Then
On Error Resume Next
Collection.Add Data(r, 1), Data(r, 1)
If Err.Number = 0 Then
Addresses = Addresses & Trim(Data(r, 1)) & ";"
End If
On Error GoTo 0
End If
Next
Rem Remove extra semi-colon
If Len(Addresses) > 0 Then DashboardEmailList = Left(Addresses, Len(Addresses) - 1)
End Function
Notice how I broke the sub routine down into small easy to test functions and sub-routines.
Private Sub CommandButton1_Click()
Dim DashboardMap As Object
Set DashboardMap = DashboardEmailList
Dim Key As Variant
Const olMailItem = 0
' Set Outlook object.
Dim objOutlook As Object
Set objOutlook = CreateObject("Outlook.Application")
For Each Key In DashboardMap
Dim Dashboard As String, Addresses As String
' Create email object.
Dashboard = Key
Addresses = DashboardMap(Key)
Debug.Print Dashboard, Addresses
Dim objEmail As Object
Set objEmail = objOutlook.CreateItem(olMailItem)
With objEmail
.To = Addresses ' Assign all email ids to the property.
.Subject = "This is a test message"
.Body = "Hi, there. Hope you are doing well."
.Display ' Display outlook message window.
End With
Next
' Clear all objects.
Set objEmail = Nothing: Set objOutlook = Nothing
End Sub
Function DashboardRange() As Range
Set DashboardRange = Sheet1.Range("A1").CurrentRegion
End Function
Function DashboardEmailList() As Object
If DashboardRange.Rows.Count = 1 Then Exit Function
Dim Data As Variant
Data = DashboardRange.Value
Dim Dictionary As Object
Set Dictionary = CreateObject("Scripting.Dictionary")
Dim Addresses As String
Dim Key As String, Value
Dim r As Long
For r = 2 To UBound(Data)
If Trim(Data(r, 1)) <> "" And Trim(Data(r, 2)) <> "" Then
Key = Trim(Data(r, 1))
Value = Trim(Data(r, 2))
If Dictionary.Exists(Key) Then
Dictionary(Key) = Dictionary(Key) & ";" & Value
Else
Dictionary.Add Key, Value
End If
End If
Next
Set DashboardEmailList = Dictionary
End Function