VBA 基于 3 个条件求和值并将结果从表格转换为可视化布局

Question

大家下午好！

我试图根据三列的字符串总结在源表的“O”列中找到的值。问题是其中一列（sourceSheet“A”）是一个“年-月”字符串，而我要汇总的 targetSheet 将其从表格格式转置为可视格式（“年-月”是列 - 2023-Jan 是 Z1， 2023 年 8 月为 AG1 等）。

我尝试了各种方法来实现这一目标，但效果不佳。虽然我知道如何强力执行此操作，只需指定要使用的列并为每列再次运行它，但我正在尝试改进和使用数组。我之所以使用 VBA 而不仅仅是公式，是因为该工作簿将作为我们年度预算的模板，并且理想情况下将为每个区域加载不同范围的信息。

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

目标表：

下面是 sourceSheet 数据的模拟视觉效果，其中保留了所需的 UID，但出于安全原因，我必须删除其他数据：

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