Sum values based on three criteria and transpose result from tabular to visual layout

Question

I'm trying to summarize values found in column "O" of my sourceSheet based on the strings of three columns.

One of the columns (sourceSheet "A") is a Year-Month string, and the targetSheet I am summing to transposes this from tabular format to a visual format (Year-Month are columns - 2023-Jan is Z1, 2023-Aug is AG1, etc.).

While I know how to brute force this, specify the column and run it for each column, I am trying to improve and use arrays.

I am doing VBA instead of a formula as this workbook is to serve as a template for our yearly budget and ideally will load information with varying ranges for each region.

The results will be in a visual format similar to the table below (note, each Community Num has three rows, one for each Product).

Target sheet:

Mock visual of the sourceSheet data with required UIDs remaining but due to security I removed other data:

The code takes the length of sourceSheet and targetSheet based on columns which have no blanks (column O of sourceSheet where the sum comes from has blanks). It matches the Community Num and Product and Year-Month in the loop to try and sum the column O (Trade Count) of the sourceSheet. But what happens is that the first column to be filled (Z4) is some kind of total sum, and each subsequent cell that is populated (for some reason its every three cells) the number either stays the same or gets smaller, until it reaches the last cell of column AG where its 0.

Sub PopulateConfirmedCommunities()
    Dim sourceSheet As Worksheet
    Dim targetSheet As Worksheet
    Dim lastRow As Long
    Dim dataRange As Range
    Dim cell As Range
    Dim dataArray() As Variant
    Dim resultCollection As Collection
    Dim resultIndex As Long
    Dim targetColumns As Range
    Dim criteriaRange As Range
    Dim i As Long
    Dim columnIndex As Long
    
    ' Set source and target sheets
    Set sourceSheet = ThisWorkbook.Sheets("Region Financials")
    Set targetSheet = ThisWorkbook.Sheets("Confirmed Communities")
    
    ' Find the last row in the source sheet
    lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, "A").End(xlUp).row
    
    ' Set target columns
    Set targetColumns = targetSheet.Range("Z1:AG1")
    
    ' Initialize the result collection
    Set resultCollection = New Collection
    
    ' Loop through the data in the source sheet
    For Each cell In sourceSheet.Range("A2:A" & lastRow)
        ' Check if the Year-Month, Community Num, and Product match
        If cell.Value <> "" Then
            Set dataRange = sourceSheet.Range(cell.Offset(0, 14), sourceSheet.Cells(lastRow, 14))
            dataArray = Application.WorksheetFunction.Transpose(dataRange.Value)
            resultIndex = resultIndex + 1
            
            ' Create a new array to hold the result data
            Dim resultArray(1 To 4) As Variant
            resultArray(1) = cell.Value ' Year-Month
            resultArray(2) = cell.Offset(0, 10).Value ' Community Num
            resultArray(3) = cell.Offset(0, 13).Value ' Product
            resultArray(4) = Application.WorksheetFunction.Sum(dataArray) ' Sum TradeGroupCount
            
            ' Add the result array to the collection
            resultCollection.Add resultArray
            Set cell = cell.Offset(dataRange.Rows.Count - 1, 0)
        End If
    Next cell
    
    ' Loop through the resultCollection and populate the target sheet
    For i = 2 To resultCollection.Count
        Dim currentResultArray() As Variant
        Dim targetCell As Range
        currentResultArray = resultCollection(i)
        
        For Each targetCell In targetColumns
            If currentResultArray(1) = targetCell.Value Then
                ' Find the corresponding row in the target sheet
                Set criteriaRange = targetSheet.Range("L2:L" & targetSheet.Cells(targetSheet.Rows.Count, "L").End(xlUp).row)
                columnIndex = targetCell.Column
                On Error Resume Next
                Dim matchingRow As Range
                Set matchingRow = criteriaRange.Find(currentResultArray(2))
                On Error GoTo 0
                
                If Not matchingRow Is Nothing Then
                    ' Check if the product matches as well
                    If targetSheet.Cells(matchingRow.row, "O").Value = currentResultArray(3) Then
                        ' Populate the target sheet
                        targetSheet.Cells(matchingRow.row, columnIndex).Value = currentResultArray(4)
                    End If
                End If
            End If
        Next targetCell
    Next i
    
    ' Clear memory
    Set resultCollection = Nothing
End Sub

Answer 1

I'd maybe do it like this:

Option Explicit

Sub PopulateConfirmedCommunities()
    Dim sourceSheet As Worksheet, targetSheet As Worksheet
    Dim cell As Range, targetColumns As Range, criteriaRange As Range
    Dim i As Long, dict As Object, ym, prod, comm, amt, map As Object
    Dim targetLastRow As Long, k As String, m
    
    Set sourceSheet = ThisWorkBook.Sheets("Region Financials")
    
    Set targetSheet = ThisWorkBook.Sheets("Confirmed Communities")
    Set targetColumns = targetSheet.Range("Z1:AG1")
    targetLastRow = targetSheet.Cells(targetSheet.Rows.Count, "L").End(xlUp).Row
    'get a mapping of all unique combinations of community+product on target sheet
    Set map = RowMap(targetSheet.Range("A2:A" & targetLastRow), "L", "O")
    
    For Each cell In sourceSheet.Range("A2:A" & _
                sourceSheet.Cells(sourceSheet.Rows.Count, "A").End(xlUp).Row).Cells
        
        With cell.EntireRow      'read the values
            ym = .Columns("A").Value
            prod = .Columns("N").Value
            comm = .Columns("K").Value
            amt = .Columns("O").Value
        End With
        
        If Len(ym) > 0 And Len(amt) > 0 Then
        
            k = comm & vbTab & prod 'unique key
            
            'Uncomment if adding new rows on Target sheet
            'If Not map.Exists(k) Then 'a new combination? Add to sheet and row map
            '   targetLastRow = targetLastRow + 1
            '   With targetSheet.Rows(targetLastRow)
            '       .Columns("L").Value = comm
            '        .Columns("O").Value = prod
            '    End With
            '    dict(k) = targetLastRow
            'End If
            
            If map.Exists(k) Then
                m = Application.Match(ym, targetColumns, 0) 'match on year-month
                If Not IsError(m) Then                      'matched?
                    With targetColumns.Cells(m).EntireColumn.Cells(map(k))
                        .Value = .Value + amt
                    End With
                End If
            End If 'matched on key
        End If     'has y-m and amount
            
        
    Next cell
End Sub

'Given a range `rng`, create a dictionary with keys concatenated from all columns in
'  `colLetters`, and values being the row number.
'Assumes all unique combinations of key columns are unique (no repeats)
Function RowMap(rng As Range, ParamArray colLetters()) As Object 'scripting dictionary
    Dim rw As Range, k As String, sep As String, i As Long, dict As Object
    Set dict = CreateObject("scripting.dictionary")
    For Each rw In rng.Rows
        k = ""
        sep = ""
        For i = LBound(colLetters) To UBound(colLetters) 'loop "key" columns
            k = k & sep & rw.EntireRow.Columns(colLetters(i)).Value
            sep = vbTab 'add seperator after first value
        Next i
        dict(k) = rw.Row
    Next rw
    Set RowMap = dict
End Function