Loop through range then update worksheet reference - excel

Question

I have a document that contains a couple of macros.
First extracts data from a data sheet (datasheet) and copies to a specific worksheet (reportsheet) when the criteria is met.
Second saves this as a PDF, creates an email and sends it.
I have 100+ sheets and would require duplicating these macros 100 times.
I want to combine these into one macro. I would like to loop through a range ("B6:B123") and if in that range the cell <> 0 then the macro needs to run but the report sheet reference I'd like to update dynamically using the adjacent cell value (Dx) that would trigger these to run.
Macro 1
Sub Search_extract_135()
Dim datasheet As Worksheet
Dim reportsheet As Worksheet
Dim ocname As String
Dim finalrow As Integer
Dim i As Integer
Set datasheet = Sheet121 ' stays constant
Set reportsheet = Sheet135 'need to update based on range that <>0 then taking cell reference as
ocname = reportsheet.Range("A1").Value 'stays constant
reportsheet.Range("A1:U499").EntireRow.Hidden = False
reportsheet.Range("A5:U499").ClearContents
datasheet.Select
finalrow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To finalrow
If Cells(i, 1) = ocname Then
Range(Cells(i, 1), Cells(i, 21)).Copy
reportsheet.Select
Range("A500").End(xlUp).Offset(1, 0).PasteSpecial xlPasteAll
datasheet.Select
End If
Next i
reportsheet.Select
Range("A4").Select
Call HideRows
End Sub
Macro 2
Sub Send_Email_135()
Dim wPath As String, wFile As String, wMonth As String, strPath As String, wSheet As Worksheet
Set wSheet = Sheet135
wMonth = Sheets("Journal").Range("K2")
wPath = ThisWorkbook.Path ThisWorkbook.Path
wFile = wSheet.Range("A1") & ".pdf"
wSheet.Range("A1:U500").ExportAsFixedFormat Type:=xlTypePDF, Filename:=wPath & "-" & wFile, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
strPath = wPath & "-" & wFile
Set dam = CreateObject("Outlook.Application").CreateItem(0)
'
dam.To = wSheet.Range("A2")
dam.cc = wSheet.Range("A3")
dam.Subject = "Statement " & wMonth
dam.Body = "Hi" & vbNewLine & vbNewLine & "Please find attached your statement." & Chr(13) & Chr(13) & "Regards," & Chr(13) & "xxxxx"
dam.Attachments.Add strPath
dam.Send
MsgBox "Email sent"
End Sub
The Excel document has names in column A, numeric values in column B and SheetCode in column D.
When cell within Range("B6:B123") <> 0 then run the two macros above but need report sheet from macro 1 & wSheet from macro 2 to use the same value in column D to references the specific worksheet code for the person that doesn't equal 0.

Answer 1

The solution it to use a dictionary to convert the codenames into sheet numbers and pass parameters into the subroutines so the same code can be applied to many different sheets.
Option Explicit
Sub Reporter()
' Journal sheet layout
Const ROW_START = 6
Const COL_NZ = "B" ' column to check <> 0
Const COL_CODE = "D" ' sheet codenames
' Fixed sheet code names
Const WS_DATA = "Sheet121"
Const WS_JOURNAL = "Sheet5"
Dim wb As Workbook, ws As Worksheet
Dim wsReport As Worksheet, wsJournal As Worksheet, wsData As Worksheet
Dim iLastRow As Long, i As Long, n As Long
Dim sCodeName As String, sMonth As String
' build a dictionary of codename->sheetno
Dim dict As Object, key As String
Set dict = CreateObject("Scripting.Dictionary")
Set wb = ThisWorkbook
For Each ws In wb.Sheets
dict.Add ws.CodeName, ws.Index
Next
' assign Fixed sheets
Set wsData = wb.Sheets(dict(WS_DATA)) ' or Sheet121
Set wsJournal = wb.Sheets(dict(WS_JOURNAL)) ' or Sheet5
sMonth = wsJournal.Range("K2")
' scan list of persons
With wsJournal
iLastRow = .Cells(Rows.Count, COL_CODE).End(xlUp).Row
For i = ROW_START To iLastRow
If .Cells(i, COL_NZ) <> 0 Then ' col B
sCodeName = .Cells(i, COL_CODE) ' col D
' set sheet, create report and email it
Set wsReport = wb.Sheets(dict(sCodeName))
Call Create_Report(wsReport, wsData)
Call Email_Report(wsReport, sMonth)
n = n + 1
End If
Next
End With
MsgBox n & " emails sent", vbInformation
End Sub
Sub Create_Report(wsReport As Worksheet, wsData)
Dim ocname As String, iLastRow As Long, i As Long
Dim rngReport As Range
With wsReport
ocname = .Range("A1").Value 'stays constant
.Range("A1:U500").EntireRow.Hidden = False
.Range("A5:U500").ClearContents
Set rngReport = .Range("A5")
End With
' scan down data sheet and copy to report sheet
Application.ScreenUpdating = False
With wsData
iLastRow = .Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To iLastRow
If wsData.Cells(i, 1) = ocname Then
.Cells(i, 1).Resize(1, 21).Copy rngReport
Set rngReport = rngReport.Offset(1)
End If
Next i
End With
'Call HideRows
Application.ScreenUpdating = True
End Sub
Sub Email_Report(wsReport As Worksheet, sMonth As String)
Dim sPDFname As String, oMail As Outlook.MailItem
sPDFname = ThisWorkbook.Path & "\" & wsReport.Range("A1") & ".pdf"
Dim oOut As Object ' Outlook.Application
Set oOut = CreateObject("Outlook.Application")
Set oMail = oOut.CreateItem(0)
With oMail
wsReport.Range("A1:U500").ExportAsFixedFormat _
Type:=xlTypePDF, Filename:=sPDFname, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
.To = wsReport.Range("A2").Value2
.cc = wsReport.Range("A3").Value2
.Subject = "Statement " & sMonth
.Body = "Hi" & vbNewLine & vbNewLine & _
"Please find attached your statement." & vbCr & vbCr & _
"Regards," & vbCr & "xxxxx"
.Attachments.Add sPDFname
.Display ' or .Send
End With
MsgBox "Email sent to " & wsReport.Range("A2").Value2, , wsReport.Name
oOut.Quit
End Sub