If Statement Send Email to Specific Address Macro

[cts5106]

Hi all,

I have a set of data that I need to send an email to a specific individual if their name is in the cell.

I typically copy and paste several cells into the body of an email and send it to the individual in the cell that it pertains to however I would like to create a macro that can do this for me. I am trying to write something along the lines of filter on name, copy header and all cells affiliated with name, look up email for name, open email, paste information, send email to specific email address and then do it again for the next name.

I provided an example spreadsheet. In the first tab has the names of individuals and the information that pertains to them and in the next tab has the names and email addresses.

Any help would be greatly greatly appreciated!!

 

[ranman256]

since I cannot upload the working workbook. Run: LoadEmails

Here's the code:

Option Explicit
Public gcolEmails As Collection
  'gather the emails

Private Sub LoadEmails()
Dim sName As String
Dim vEmail
Set gcolEmails = New Collection
Sheets("emails").Activate
Range("A2").Select
While ActiveCell.Value <> ""
   sName = ActiveCell.Offset(0, 0).Value
   vEmail = ActiveCell.Offset(0, 1).Value
  
   gcolEmails.Add vEmail, sName
   ActiveCell.Offset(1, 0).Select 'next row
Wend
End Sub



Public Sub SendAllEmails()
Dim vTo, vSubj, vBody, vTrans, vInfo, vStart, vEnd, vLoc
Dim sName As String
LoadEmails
Sheets("territories").Activate
Range("A2").Select
While ActiveCell.Value <> ""
   vTrans = "Trans#:" & ActiveCell.Offset(0, 1).Value
   sName = ActiveCell.Offset(0, 2).Value
   vInfo = "info: " & ActiveCell.Offset(0, 3).Value
   vStart = ActiveCell.Offset(0, 4).Value
   vEnd = ActiveCell.Offset(0, 5).Value
   vLoc = "location: " & ActiveCell.Offset(0, 6).Value
  
   vTo = gcolEmails(sName)
   vSubj = sName & " territory info"
   vBody = vTrans & vbCrLf & vInfo & vbCrLf & "start: " & vStart & " End: " & vEnd & vbCrLf & vLoc
  
  
   Send1Email vTo, vSubj, vBody
  
   ActiveCell.Offset(1, 0).Select 'next row
Wend
Set gcolEmails = Nothing
End Sub



'-------
'YOU MUST ADD THE OUTLOOK APP IN REFERENCES!!!   checkmark MICROSOFT OUTLOOK OBJECT LIBRARY in the vbE menu, Tools, References
'-------
 private Function Send1Email(ByVal pvTo, ByVal pvSubj, ByVal pvBody, Optional pvFile) As Boolean
Dim oApp As Outlook.Application
Dim oMail As Outlook.MailItem
On Error GoTo ErrMail
Set oApp = GetApplication("Outlook.Application")
'Set oApp = CreateObject("Outlook.Application")
Set oMail = oApp.CreateItem(olMailItem)
With oMail
    .To = pvTo
    .Subject = pvSubj
    .Body = pvBody
     If Not IsMissing(pvFile) Then .Attachments.Add pvFile, olByValue, 1
  
    '.Send
    .Display True
End With
Send1Email = True
Set oMail = Nothing
Set oApp = Nothing
Exit Function
ErrMail:
MsgBox Err.Description, , Err
End Function


private Function GetApplication(className As String) As Object
' function to encapsulate the instantiation of an application object
Dim theApp As Object
On Error Resume Next
Set theApp = GetObject(, className)
If Err.Number <> 0 Then
    MsgBox "Unable to Get" & className & ", attempting to CreateObject"
    Set theApp = CreateObject(className)
End If
If theApp Is Nothing Then
    Err.Raise Err.Number, Err.Source, "Unable to Get or Create the " & className & "!"
    Set GetApplication = Nothing
End If
'MsgBox "Successfully got a handle on Outlook Application, returning to caller"
Set GetApplication = theApp
End Function