single Email address from one sheet - multiple data from another
 

Sheets("Email Data").Select
ReDim arrContractor(1 To lRowCountEmail) ' declares the array
variable with the necessary size
ReDim arrEndDate(1 To lRowCountEmail) ' declares the array variable
with the necessary size
ReDim arrWeeksRemain(1 To lRowCountEmail) ' declares the array
variable with the necessary size
ReDim arrReportsTo(1 To lRowCountEmail) ' declares the array
variable with the necessary size


For m = 1 To lRowCountEmail - 1
ActiveCell.Offset(1, 0).Select
arrContractor(m) = ActiveCell.Offset(0, -3).Value ' name of
contractor is in col D
arrEndDate(m) = ActiveCell.Offset(0, 7).Value ' current contract
ends is in col N
arrReportsTo(m) = ActiveCell.Value ' current contract ends is in
col N
arrWeeksRemain(m) = ActiveCell.Offset(0, 12).Value ' weeks
remaining is in col S

' data is now in the arrays, now get it out in email


'ReDim arrEmailAdd(1 To lRowCountRef) ' declares the array variable
with the necessary size
'ReDim arrReportsToEmail(1 To lRowCountRef) ' declares the array
variable with the necessary size


y = 1
m = 1

For Each j In arrReportsTo()
'MsgBox arrEmailAdd(3)
' If j = arrReportsTo(m) Then
strBodyC = strBodyC & vbCrLf & "Name: " & arrContractor(m)
strBodyC = strBodyC & vbCrLf & "Current Contract End Date: " &
arrEndDate(m)
strBodyC = strBodyC & vbCrLf & "Weeks Remaining: " &
arrWeeksRemain(m)
strBodyC = strBodyC & vbCrLf & ""
' need to put in here not to write over
' Else
' End If
' ActiveCell.Offset(1, 0).Select
'Next

' ActiveCell.Offset(1, 0).Select
If arrContractor(m) = "" Then
Else
arrReportsTo(m) = Left(arrReportsTo(m), InStr(arrReportsTo(m), " ")
- 1)
strBody = "Dear " & arrReportsTo(m) & vbCrLf & vbCrLf 'Create some
body text
strBody = strBody & "The contracts for the following people are due
to expire" & vbCrLf
strBody = strBody & vbCrLf & "If you have not done so - please sort
it out"

strBody = strBody & vbCrLf
strBody = strBody & vbCrLf & ""
strBody = strBody & vbCrLf & "Many Thanks"
strBody = strBody & vbCrLf & ""
strBody = strBody & vbCrLf & "Project Office"
Set itmMail = olApp.CreateItem(olMailItem)
With itmMail
.Subject = "Contractor Expiry Dates" 'Add the subject of the
mail message
.Body = strBody
'Add a recipient and test to make sure that the address is valid
using the Resolve method

strEmailAdd = CStr(arrEmailAdd(m))
With .Recipients.Add(strEmailAdd)
.Type = olTo
If Not .Resolve Then
MsgBox "Unable to resolve address." & arrEmailAdd(j), vbInformation
Exit Sub
End If
End With
.Display
'.Send 'Send the mail message
End With
End If

m = m + 1
Next

y = 1 + y
Next ' lRowRef ' end of email to reports to
'Next

'Release memory
Set itmMail = Nothing
Set nsMAPI = Nothing
Set olApp = Nothing