Search code examples
arraysexcelvbaoutlookspreadsheet

Sending Email to multiple recipients using VBA.array


I have the recipients listed in a VBA.array. The use for this is because it is matching the nth position of the other arrays. I am experiencing a problem when trying to reference two cells that are in different locations of the sheet for the recipient email address. Let's say for example on the second range I want the recipients to be email addresses listed in both A1 and E63 and they should be included on the same message not sent separate emails.

Option Explicit

Private WorksheetNames As Variant
Private ValueRanges As Variant
Private OldValues As Variant

Private Sub Workbook_Open()
    WorksheetNames = VBA.Array("Info", "Info")
    ValueRanges = VBA.Array("E16:E20", "E22:E25")
    OldValues = GetValues
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    ComposeAndSendMails
End Sub

Private Sub ComposeAndSendMails()
    
    Const COPY_COLUMNS As String = "A:E"
    Const ROW_DELIMITER As String = vbLf
    Const COL_DELIMITER As String = " - "
    Dim cIndices(): cIndices = VBA.Array(1, 2, 3, 5) ' skip column 'D'
    Dim Recipients(): Recipients = VBA.Array("E61", "E63")
    
    Dim rLen As Long: rLen = Len(ROW_DELIMITER)
    Dim cLen As Long: cLen = Len(COL_DELIMITER)
    Dim cUpper As Long: cUpper = UBound(cIndices)
    
    Dim BaseName As String:
    With ThisWorkbook
        BaseName = Left(.Name, InStrRev(.Name, ".") - 1)
    End With
    
    Dim NewValues(): NewValues = GetValues
    If IsEmpty(GetValues) Then Exit Sub ' covered in 'GetValues'
    
    Dim bData(), n As Long, r As Long, c As Long, eCount As Long
    Dim Body As String, Recipient As String
    
    For n = 0 To UBound(NewValues)
        If IsColumnDifferent(OldValues(n), NewValues(n)) Then
            With ThisWorkbook.Sheets(WorksheetNames(n))
                bData = .Range(ValueRanges(n)).EntireRow _
                    .Columns(COPY_COLUMNS).Value
                Recipient = CStr(.Range(Recipients(n)).Value)
            End With
            For r = 1 To UBound(bData, 1)
                For c = 0 To cUpper
                    Body = Body & bData(r, cIndices(c)) & COL_DELIMITER
                Next c
                Body = Left(Body, Len(Body) - cLen)
                Body = Body & ROW_DELIMITER
            Next r
            Body = Left(Body, Len(Body) - rLen)
            SendMailSimple BaseName, Recipient, Body
            eCount = eCount + 1
            Body = ""
        End If
    Next n

    If eCount > 0 Then
        OldValues = NewValues
    End If
    
    MsgBox IIf(eCount = 0, "No", eCount) & " message" _
        & IIf(eCount = 1, "", "s") & " sent.", _
            IIf(eCount = 0, vbExclamation, vbInformation)

End Sub

Private Function GetValues() As Variant
    
    If IsEmpty(WorksheetNames) Then
        MsgBox "The initial information got lost!", vbExclamation
        Exit Function
    End If
 
    Dim UB As Long: UB = UBound(WorksheetNames)
    Dim Jag(): ReDim Jag(0 To UB)
    
    Dim n As Long
 
    For n = 0 To UB
        With ThisWorkbook.Sheets(WorksheetNames(n)).Range(ValueRanges(n))
            Jag(n) = .Value
        End With
    Next n
        
    GetValues = Jag
 
End Function

Function IsColumnDifferent( _
    ByVal OldData As Variant, _
    ByVal NewData As Variant, _
    Optional ByVal ColumnIndex As Long = 1) _
As Boolean
    Dim r As Long
    For r = LBound(OldData, 1) To UBound(OldData, 1)
        If CStr(OldData(r, ColumnIndex)) <> CStr(NewData(r, ColumnIndex)) Then
            IsColumnDifferent = True
            Exit For
        End If
    Next r
End Function

Sub SendMailSimple( _
         ByVal Subject As String, _
         ByVal Recipient As String, _
         ByVal Body As String)
    With CreateObject("Outlook.Application").CreateItem(0)
        .Subject = Subject
        .To = Recipient
        .Body = Body
        .Send
    End With
End Sub

I received help on this code from user VBasic, but he hasn't responded to my follow up question for a few days, so I am hoping to receive more help in this thread.


Solution

  • Add A1 into array

        Recipients = VBA.Array("E61", "A1,E63")
    

    and edit code

        'Recipient = CStr(.Range(Recipients(n)).Value)
        Dim cel As Range
        Recipient = ""
        For Each cel In .Range(Recipients(n))
           Recipient = Recipient & ";" & CStr(cel)
        Next
        Recipient = Mid(Recipient, 2)