VBA to loop through range then run code updating worksheet reference

Question

Sorry I am a newbie looking for help. I am having a complete mind block so reaching out for some help.

I have a document that contains a couple of macros; 1st extracts data from a data sheet (datasheet) and copies to a specific worksheet (reportsheet) when the criteria is met. The 2nd macro will save this as a PDF, create an email and send it to the person.

I have 100+ sheets and would require to duplicate these macros 100 times.

I want to combine these into 1 macro, however, i would like to loop through a range ("B6:B123") and if in that range the cell <> 0 then the macro need 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

I am hoping this makes sense.

will try to summarise below;

The format of 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 2 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.

If this isn't going to work I will create multiple macros.

Thank you in advance.

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