Yeah, that's spot on! I think there will be over 170 rows if that's of any use?
OK, so I may be making this over complicated, but I think this will work for you nicely. It will:
- Check if workbook B is open or not and will open it if required (there is some additional code that needs to be added to your workbook, I'll get to that in a minute)
- Work out how many departments are in Sheet1 column A of workbook A (assumes there are no headers)
- Work out how many email addresses are in Sheet1 column A of workbook B (assumes there are no headers)
- Systematically work through each department in workbook A and send the corresponding email if possible
- Display an optional message for any departments where it doesn't find a match
- Display a message at the end to confirm it has checked all entries from workbook A
You will need to amend any parts in bold red to correctly reflect the actual filepath for workbook B.
You may also want to delete the whole bold blue section if you don't want to see messages relating to departments that cannot be found in workbook B.
If the sheets we are looking at in each workbook are not actually the first sheet then you will need to change the bold green Sheet(1) parts to correctly reflect what number tab we are dealing with, e.g. Sheets(3) would be whatever is the 3rd tab.
If workbook A has headers then you will need to change Set cRange = wb1.Sheets(1).Range("A1:A" & LastRow1) to Set cRange = wb1.Sheets(1).Range("A2:A" & LastRow1)
If workbook B has headers then you will need to change Set lRange = wb2.Sheets(1).Range("A1:A" & LastRow1) to Set lRange = wb2.Sheets(1).Range("A2:A" & LastRow1)
The first thing you will want to do is put the following code in a standard module in your workbook (the same as your main macro is fine). This code contains a function for checking if a workbook is already open or not. I have referenced this in my tweaked macro for you so it is essential you add it in:
Rich (BB code):
Function IsFileOpen(filename As String)
' Defines variables
Dim filenum As Integer, errnum As Integer
On Error Resume Next ' Turn error checking off.
filenum = FreeFile() ' Get a free file number.
' Attempt to open the file and lock it.
Open filename For Input Lock Read As #filenum
Close filenum ' Close the file.
errnum = Err ' Save the error number that occurred.
On Error GoTo 0 ' Turn error checking back on.
' Check to see which error occurred.
Select Case errnum
' No error occurred.
' File is NOT already open by another user.
Case 0
IsFileOpen = False
' Error number for "Permission Denied."
' File is already opened by another user.
Case 70
IsFileOpen = True
' Another error occurred.
Case Else
Error errnum
End Select
End Function
Once you have that in place, replace your original macro with the following. This has the highlighted parts I mentioned above which may need changing:
Rich (BB code):
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'''
' Sets wb1 as the main workbook
Set wb1 = ThisWorkbook
' 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:\TestFolder\PontyBiker\emaillist.xlsx") Then
' Open and Sets wb2 as emaillist.xlsx (amend file path as required)
Set wb2 = Workbooks.Open("C:\TestFolder\PontyBiker\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 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
' Display message that the department was not found and move on
MsgBox FindString & " department not found. Moving on."
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("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
