根据三个标准对值求和，并将结果从表格转置为视觉布局

Question

我正在尝试根据三列的字符串总结在我的源表“O”列中找到的值。

其中一列（sourceSheet“A”）是一个“年-月”字符串，我总结的目标表将其从表格格式转置为视觉格式（“年-月”是列 - 2023 年 1 月是 Z1，2023 年 8 月）是 AG1 等）。

虽然我知道如何强力执行此操作，指定列并为每列运行它，但我正在尝试改进和使用数组。

我正在使用 VBA 而不是公式，因为此工作簿将作为我们年度预算的模板，并且理想情况下将为每个地区加载不同范围的信息。

结果将采用类似于下表的视觉格式（注意，每个社区编号有三行，每个产品一行）。

目标表：

sourceSheet 数据的模拟视觉效果，其中保留了所需的 UID，但出于安全考虑，我删除了其他数据：

代码根据没有空格的列（总和来自的 sourceSheet 的 O 列有空格）获取 sourceSheet 和 targetSheet 的长度。它匹配循环中的社区编号、产品和年月，以尝试对源表的 O 列（交易计数）求和。但会发生的情况是，要填充的第一列 (Z4) 是某种总和，并且填充的每个后续单元格（由于某种原因每三个单元格）的数字要么保持不变，要么变小，直到达到AG 列的最后一个单元格为 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

我可能会这样做：

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