Sub CreateMail()
Dim objOutlook As Object
Dim objMail As Object
Dim rngTo As Range
Dim rngSubject As Range
Dim rngBody As Range
Dim rngAttach As Range
Dim strTo As String
Dim ws1 As Worksheet: Set ws1 = Worksheets("Sheet1")
Dim ws2 As Worksheet: Set ws2 = Worksheets("Sheet2")
Dim lRowsht1 As Single
Dim lRowsht2 As Single
Dim cRow As Single
Dim i As Integer
Dim strBody As String
Dim n As Single
Dim emL As String
Dim NmCt As Integer
strBody = ""
NmCt = 0
'||||||||||||||||||||||| Get Last Row of Data On Two Sheets |||||||||||||||||
lRowsht1 = ws1.Cells(Rows.Count, "I").End(xlUp).Row
lRowsht2 = ws2.Cells(Rows.Count, "A").End(xlUp).Row
'||||||||||||||||||||||| Get Name To Search For |||||||||||||||||||||||||||||||
strTo = UCase(InputBox("Please Enter Name to Search For..."))
'||||||||||||||||||| Search Name Range Sheet1 ||||||||||||||||||||||||||||||||
For i = 2 To lRowsht1
If Cells(i, 9).Value = strTo Then GoTo stOver
Next
GoTo Err_Handler
'||||||||||||||||||||||| Copy Name Row For Body of Email|||||||||||||||||||||||||||||
stOver:
If NmCt >= 1 Then strBody = ""
cRow = i
For i = 1 To 15
strBody = strBody & " " & Cells(cRow, i).Value
Next
NmCt = NmCt + 1
'||||||||||||||||||||||| Get Email Addrress From Sheet2 ||||||||||||||||||||||
For n = 2 To lRowsht2
If ws2.Cells(n, 1).Value = strTo Then
emL = ws2.Cells(n, 1).Offset(0, 1).Value
GoTo cr8ml
End If
Next
'|||||||||||||||||||||||| Search For Name Repeats ||||||||||||||||||||||||||||||
Lkagn:
If NmCt >= 1 Then
For i = cRow + 1 To lRowsht1
If Cells(i, 9).Value = strTo Then GoTo stOver
Next
End If
End
'||||||||||||||||||||||| Create Email in Outlook |||||||||||||||||||||||||
cr8ml:
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With objMail
'.to = rngTo.Value
.To = emL
'.Subject = rngSubject.Value
'.Body = rngBody.Value
.body = strBody
'.Attachments.Add rngAttach.Value
.Display 'Instead of .Display, you can use .Send to send the email _
or .Save to save a copy in the drafts folder
End With
Set objOutlook = Nothing
Set objMail = Nothing
Set rngTo = Nothing
Set rngSubject = Nothing
Set rngBody = Nothing
Set rngAttach = Nothing
'|||||||||||||||||||||| Start Over ||||||||||||||||||||||||
GoTo Lkagn
End
Err_Handler:
If NmCt = 0 Then MsgBox "Name Not Found", vbInformation, "Name Search"
End Sub
