Loop through range then update worksheet reference

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