Sub MailWithLookupLoop()
' Defines variables
Dim wb1 As Workbook, wb2 As Workbook, FindString As String, EmailAdd As String, Cell As Range, cRange As Range, lRange As Range
' Disable screen updating to reduce flicker
Application.ScreenUpdating = False
'''SETUP WORKBOOK 1'''
' If Telephone-Charges is not already open (amend file path as required) then...
If Not IsFileOpen("C:\Users\sm18441\Documents\Call Logger\Telephone-Charges.xlsx") Then
' Open and Sets wb1 as Telephone-Charges.xlsx (amend file path as required)
Set wb1 = Workbooks.Open("C:\Users\sm18441\Documents\Call Logger\Telephone-Charges.xlsx")
' Re-activate wb1
wb1.Activate
' Else if EmailList is already open then...
Else
' Sets wb1 as Telephone-Charges.xlsx
Set wb1 = Workbooks("Telephone-Charges.xlsx")
End If
' Defines LastRow1 as the last row of data on wb1 sheet1 based on column A
LastRow1 = wb1.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row
' Sets the check range as A1 to the last row of A on wb1 sheet1
Set cRange = wb1.Sheets(1).Range("A1:A" & LastRow1)
'''SETUP WORKBOOK 2'''
' If EmailList is not already open (amend file path as required) then...
If Not IsFileOpen("C:\Users\sm18441\Documents\Call Logger\emaillist.xlsx") Then
' Open and Sets wb2 as emaillist.xlsx (amend file path as required)
Set wb2 = Workbooks.Open("C:\Users\sm18441\Documents\Call Logger\emaillist.xlsx")
' Re-activate wb1
wb1.Activate
' Else if EmailList is already open then...
Else
' Sets wb2 as emaillist.xlsx
Set wb2 = Workbooks("emaillist.xlsx")
End If
' Defines LastRow2 as the last row of data of wb2 sheet1 based on column A
LastRow2 = wb2.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row
' Sets lookup range as A1 to the last row of B on wb2 sheet1
Set lRange = wb2.Sheets(1).Range("A1:B" & LastRow2)
'''START LOOP'''
' For each cell in the check range
For Each Cell In cRange
' Sets variable FindString as the contents of the current cell on wb1 sheet1
FindString = Cell.Value
' On error continue
On Error Resume Next
' Sets variable EmailAdd to nothing
EmailAdd = ""
' Sets variable EmailAdd as the corresponding email address based on the FindString on wb2 sheet1
EmailAdd = Application.WorksheetFunction.VLookup(FindString, lRange, 2, False)
'''
'''OPTIONAL MESSAGE IF DEPARTMENT IS NOT FOUND - DELETE THE BELOW SECTION FOR SEAMLESS PROCESSING'''
' If an error is encountered then...
If Err.Number <> 0 Then
If Left(FindString, 4) = "CSAD" Then
EmailAdd = "PUT THE DESIRED DEFAULT EMAIL ADDRESS HERE"
Else
' Display message that the department was not found and move on
MsgBox FindString & " department not found. Moving on."
End If
End If
'''END OF OPTIONAL MESSAGE PART - DELETE THE ABOVE SECTION FOR SEAMLESS PROCESSING'''
'''
' If EmailAdd is not blank then
If EmailAdd <> "" Then
' Select the range of cells on the ws1 as this is what will be emailed
wb1.Sheets(1).Range("A6:H6", "A" & Cell.Row, "D" & Cell.Row).Select
' Show the envelope on the ActiveWorkbook
ActiveWorkbook.EnvelopeVisible = True
With ActiveSheet.MailEnvelope
' Sets the optional introduction fields thats adds
.Introduction = "This is what will be in the opening of your email"
' Send to the email address in EmailAdd
.Item.To = EmailAdd
' Define your desired subject line
.Item.Subject = "Your chosen email subject"
' Send the email
.Item.Send
End With
End If
' Check next cell in check range
Next Cell
'''END LOOP'''
' Re-enable screen updating
Application.ScreenUpdating = True
' Display message box to confirm the process has completed
MsgBox "All mails sent."
End Sub
