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

CodePudding user response：

Is this what you are trying? (UNTESTED)

Dim UItem As New Collection
Dim aCell As Range
Dim itm As Variant
Dim i As Long: i = 1

On Error Resume Next
For Each aCell In Rng
    UItem.Add aCell.Value2, CStr(aCell.Value2)
Next aCell
On Error GoTo 0

For Each itm In UItem
    Range("D" & i) = itm
    i = i   1
Next

CodePudding user response：

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.