excel - Looping through dynamic ranges on another sheet for rows with specific text in VBA

Question

I have a macro that does a lot of things to build a report. Its a template named "Report" that has a user add another sheet, via GetOpenFile, with data to parse. The intent is to have the user open the book, push the button, select a file and generate a full report.

The data sheet, imported and renamed "Source" contains a row of headers and a variably long list of work orders. Each row contains a reference to a product code and and multiple references to order status. I have part of the macro pulling the product codes from Source column O and sorting alphabetically without duplicates.

    Sub ReportBuilder()

    'Variables for opening and copying the Sourcesheet, building and formatting the report.
    Dim sImportFile As String, sFile As String, cellName As String
    Dim sThisBk As Workbook, wbBk As Workbook
    Dim wSheet As Worksheet, sSheet As Worksheet, keepThis As Worksheet
    Dim nameRange As Range, orderRange As Range
    Dim rowCounterW As Integer, rowCounterS As Integer, pediCounter As Integer, adhoCounter As Integer, workCounter As Integer, holdCounter As Integer

    'Turns off display of screen updates and alerts.
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    'Removes all but the summary sheet "Report".
    For Each keepThis In Application.ActiveWorkbook.Worksheets
        If keepThis.Name <> "Report" Then
            keepThis.Delete
        End If
    Next

    'Displays an open file dialog box for selecting the target Source file.
    Set sThisBk = ActiveWorkbook
    sImportFile = Application.GetOpenFilename( _
    FileFilter:="Microsoft Excel Workbooks, *.xls; *.xlsx", Title:="Select a file saved from Source")

    'Handles no sheet selection.
    If sImportFile = "False" Then
        MsgBox "No File Selected!"
        Exit Sub

    'Opens the targeted file and copies the sheet.
    Else
        sFile = Dir(sImportFile)
        Application.Workbooks.Open fileName:=sImportFile
        Set wbBk = Workbooks(sFile)
        With wbBk
            Set wSheet = .Sheets("Sheet1")
            wSheet.Copy after:=sThisBk.Sheets("PBUS Report")
            ActiveSheet.Name = "Source"
            Sheets("PBUS Report").Activate
            wbBk.Close SaveChanges:=False
        End With
    End If

    'Clears everything below the headers.
    Worksheets("Report").Rows(7 & ":" & Worksheets("Report").Rows.Count).Delete

    'Inserts the list of unique PRODICT CODEs from the Source sheet.
    Set wSheet = Worksheets("Report")
    Set sSheet = Worksheets("Source")
    sSheet.Activate
    sSheet.Range("O2", Cells(Rows.Count, "O").End(xlUp)).Copy
    wSheet.Activate
    wSheet.Range("B7").PasteSpecial

    'Sorts and adjusts after paste, also captures the range of PRODUCT CODEs.
    Selection.Interior.Color = xlNone
    Selection.Font.Bold = False
    wSheet.Columns("B:B").EntireColumn.AutoFit
    Application.Selection.RemoveDuplicates Columns:=1, Header:=xlNo
    Set nameRange = wSheet.Range("B7", Cells(Rows.Count, "B").End(xlUp))
    nameRange.Sort key1:=ActiveCell, order1:=xlAscending

This part works great, I get a unique and alphabetized list of product codes from Source column O starting at row 2 in Report column B starting at row 7.

I'm stuck with the loop that counts rows on the Source sheet. For every unique product code in Report (column B starting at 7), I need to count the number of rows in Source (column O starting at 2) where the code matches AND another column contains a status description. Descriptions being either "Plant" or "Storage" in Source column Z, or "Working" or "Holding" in Source column C. There are more descriptions in either but I only track those 4 per product code.

    'Loop through the range of PRODUCT CODEs to build report.
    Set orderRange = sSheet.Range("O2", sSheet.Cells(Rows.Count, "O").End(xlUp))
    rowCounterW = 7 'Starting offset for populating the report.
    For Each c In nameRange.Rows
        pediCounter = 0 'Counter for pedigree column.
        adhoCounter = 0 'Counter for ad-hoc column.
        workCounter = 0 'Counter for working column.
        holdCounter = 0 'Counter for hold column.
        cellName = c.Value

        For Each d In orderRange.Rows
             rowCounterS = orderRange.Row + 1
             If sSheet.Cells(rowCounterS, "O") = cellName Then 'If the program name matches on both sheets.
                If sSheet.Cells(rowCounterS, "Z") = "Plant" Then
                    pediCounter = pediCounter + 1 'Counts for pedigree column.
                End If
                If sSheet.Cells(rowCounterS, "Z") = "Storage" Then
                    adhoCounter = adhoCounter + 1 'Counts for ad-hoc column.
                End If
                If sSheet.Cells(rowCounterS, "C") = "Working" Then
                    workCounter = workCounter + 1 'Counts for working column.
                End If
                If sSheet.Cells(rowCounterS, "C") = "Holding" Then
                    holdCounter = holdCounter + 1 'Counts for hold column.
                End If
            End If

        Next d
        wSheet.Cells(rowCounterW, "C") = pediCounter
        wSheet.Cells(rowCounterW, "D") = adhoCounter
        wSheet.Cells(rowCounterW, "E") = wSheet.Cells(rowCounterW, "C") + wSheet.Cells(rowCounterW, "D")
        wSheet.Cells(rowCounterW, "F") = workCounter
        wSheet.Cells(rowCounterW, "G") = holdCounter
        wSheet.Cells(rowCounterW, "H") = wSheet.Cells(rowCounterW, "E") + wSheet.Cells(rowCounterW, "F") + wSheet.Cells(rowCounterW, "G")
        rowCounterW = rowCounter + 1
    Next c

This iteration does not count or populate correctly, but it does compile. It only populates the row of B7 with 0s and gives up. I am trying to accomplish:

    For Each "product code" in "range of product codes" on Report
        For Each row on Source starting at 2
            If "that row" contains a matching "product code" from Report 
                And If "that row" also contains "desired status1"
                    Add 1 to counter for "desired status1"
                And If "that row" also contains "desired status2" 
                    Add 1 to a counter for "desired status2"
                etc...
    Populate Report column C with status 1 from the counter
    Populate Report column D with status 2 from the counter
    etc...
    Next "product code"

How did I mess this up? Trying all day with variations on that syntax once got all the fields to populate with status numbers, but they were all 0s like the first row. Currently only getting top row populating 0s. I don't understand why the dynamic range worked once to get the unique product code list once but not in the next step to loop.

EDIT: Caught a typo with rowCounterW at the bottom that stopped it from looping more than once. Also replaces some variables to count rows on the Source sheet better. Working as follows:

    'Loop through the range of PRODUCT CODEs to build report.
    rowCounterW = 7 'Starting offset for populating the report.
    For Each c In nameRange
        pediCounter = 0 'Counter for pedigree column.
        adhoCounter = 0 'Counter for ad-hoc column.
        workCounter = 0 'Counter for working column.
        holdCounter = 0 'Counter for hold column.
        cellName = c.Value

        For i = 2 To sSheet.Cells(Rows.Count, 2).End(xlUp).Row
            If sSheet.Cells(i, "O") = cellName Then 'If the program name matches on both sheets.
                If sSheet.Cells(i, "Z") = "Plant" Then
                    pediCounter = pediCounter + 1 'Counts for pedigree column.
                End If
                If sSheet.Cells(i, "Z") = "Storage" Then
                    adhoCounter = adhoCounter + 1 'Counts for ad-hoc column.
                End If
                If sSheet.Cells(i, "C") = "Working" Then
                    workCounter = workCounter + 1 'Counts for working column.
                End If
                If sSheet.Cells(i, "C") = "Holding" Then
                    holdCounter = holdCounter + 1 'Counts for hold column.
                End If
            End If
        Next i
        'Populates the report after parsing every row.
        wSheet.Cells(rowCounterW, "C") = pediCounter
        wSheet.Cells(rowCounterW, "D") = adhoCounter
        wSheet.Cells(rowCounterW, "E") = wSheet.Cells(rowCounterW, "C") + wSheet.Cells(rowCounterW, "D")
        wSheet.Cells(rowCounterW, "F") = workCounter
        wSheet.Cells(rowCounterW, "G") = holdCounter
        wSheet.Cells(rowCounterW, "H") = wSheet.Cells(rowCounterW, "E") + wSheet.Cells(rowCounterW, "F") + wSheet.Cells(rowCounterW, "G")
        rowCounterW = rowCounterW + 1
    Next c

Answer 1

Sorry I didn't take the time to match your variables, but I don't have time to fix it up (mine deals with Projects/People/Hours)...

I'd start by defining a few data structures:

Type ZCOType
    WBS As String
    ActivityType As String          
    EmployeeName As String
    ProductionOrder As String
    Hours As Double                 
End Type

Type WeeklyManpower
    StartDate As Date
    EndDate As Date
    Hours As Double
    People As Long
    Data() As ZCOType
    DataCount As Long
End Type

Public g_ManpowerData() As WeeklyManpower, g_ManpowerCount As Long

...Read the data into a variant array (for speed)

Dim vData
vData = sSheet.Range("O2", Cells(Rows.Count, "O").End(xlUp))

...Loop through the vData array more of less like it's the same as looping through rows & columns and assigning the values to the Data Structure

For iRow = 2 To iLastRow
    ' Search for an data entry, with the same Start Date
    For Index = 0 to g_ManpowerCount -1
        If StartDate = vData(iRow,1) then exit for
    Next Index
    ' If not found, create a new Record
    if Index >= g_ManpowerCount then 
        ReDim Preserve g_ManpowerData(g_ManpowerCount)
        g_ManpowerData(Index).StartDate  = vData(irow,1)            
        g_ManpowerCount = g_ManpowerCount + 1
    end if
    ' 
    With g_ManpowerData(Index)
        ReDim Preserve .Data(.DataCount)
        With .Data(.DataCount)
            .EmployeeName  = vData(irow,5)
            '....
        End With
        .DataCount=.DataCount+1
    End With        
Next

Use a custom sort function to sort the list:

Public Sub QuickSortManpower(ManpowerData() As WeeklyManpower, intBottom As Integer, intTop As Integer)

Get ready to dump the data back into the spreadsheet by putting it into a Variant array:

Dim vProjectedData
ReDim vProjectedData(g_ManpowerCount,7)
For i = 0 To g_ManpowerCount
    vProjectedData(i, 1) = ManpowerData(i).StartDate
    vProjectedData(i, 2) = ManpowerData(i).EndDate
    vProjectedData(i, 3) = ManpowerData(i).Hours
    '...
Next

And finally, dump the values onto the sheet

Sheet.Cells(2, 1).Resize(Rows + 1, 8) = vProjectedData

Add headers/formatting as needed...