Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
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 |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Critical - Converting Single Column Address Data into Multiple Col | Excel Worksheet Functions | |||
Multiple sheets as data for a single sheet | Excel Worksheet Functions | |||
Adding extra email address to a single Worksheet | Excel Programming | |||
Multiple Email address in notes | Excel Programming | |||
Emailing A single worksheet wit a email address | Excel Programming |