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.
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)