Fishboy
Well-known Member
- Joined
- Feb 13, 2015
- Messages
- 4,267
Hi all,
I am trying to help another member in THIS thread. The idea is to loop through checking one list against another list and where matches are found, to send the row from the first list as an email to the corresponding email address found in the second list. This much I have working as intended without issue.
I have now been asked to try and include the header row of A6:H6 as well as the "current" row and this is where I am having issues. In effect what I am trying to achieve is:
Now, while the above "works" it is not selecting the 2 individual rows but instead is selecting everything from the headers in row 6 all the way down to the "current" row, encompassing everything in between.
The code in its entirety can be found below. Most of it you can simply ignore as it is all working, and IsFileOpen is a user defined function included in the workbook. It is the bold section I am having difficulty with, specifically the bold red part.
Can anyone explain to me how to reference these 2 non-consecutive rows "together" so that they are what gets picked up by the email?
More information and / or the example workbooks I have been testing with are available on request if needed.
I am trying to help another member in THIS thread. The idea is to loop through checking one list against another list and where matches are found, to send the row from the first list as an email to the corresponding email address found in the second list. This much I have working as intended without issue.
I have now been asked to try and include the header row of A6:H6 as well as the "current" row and this is where I am having issues. In effect what I am trying to achieve is:
Rich (BB code):
' Sets hRange as the header row
Set hRange = wb1.Sheets(1).Range("A6:H6")
' Sets eRange as the desired row to email
Set eRange = wb1.Sheets(1).Range("A" & Cell.Row, "D" & Cell.Row)
' Select the range of cells on the ws1 as this is what will be emailed
wb1.Sheets(1).Range(hRange, eRange).SelectNow, while the above "works" it is not selecting the 2 individual rows but instead is selecting everything from the headers in row 6 all the way down to the "current" row, encompassing everything in between.
The code in its entirety can be found below. Most of it you can simply ignore as it is all working, and IsFileOpen is a user defined function included in the workbook. It is the bold section I am having difficulty with, specifically the bold red part.
Can anyone explain to me how to reference these 2 non-consecutive rows "together" so that they are what gets picked up by the email?
Rich (BB code):
Sub MailWithLookupLoop()
' Defines variables
Dim wb1 As Workbook, wb2 As Workbook, FindString As String, EmailAdd As String
Dim Cell As Range, cRange As Range, lRange As Range, eRange As Range, hRange As Range, myRange 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:\TestFolder\PontyBiker\Telephone-Charges.xlsx") Then
' Open and Sets wb1 as Telephone-Charges.xlsx (amend file path as required)
Set wb1 = Workbooks.Open("C:\TestFolder\PontyBiker\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("A7: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 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 YOUR 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
' Sets hRange as the header row
Set hRange = wb1.Sheets(1).Range("A6:H6")
' Sets eRange as the desired row to email
Set eRange = wb1.Sheets(1).Range("A" & Cell.Row, "D" & Cell.Row)
' Select the range of cells on the ws1 as this is what will be emailed
wb1.Sheets(1).Range(hRange, eRange).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 SubMore information and / or the example workbooks I have been testing with are available on request if needed.
