[FIXED] How do I create a nested loop for unique values in vba?

Issue

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

Solution

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)

Refactored Code

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.

Email Addresses Grouped by Dashboard

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

Answered By - TinMan

Answer Checked By - Pedro (PHPFixing Volunteer)