修改VBA宏使其基于Solution Sheet列表取值并在该表运行

需求说明 #

原有宏可基于Calculation工作表生成去重客户编码的统计结果，需调整逻辑满足以下要求：

• 以Solution工作表内已有的客户列表为基准输出匹配统计结果
• 支持直接在Solution工作表激活状态下运行宏，无范围引用错误

参考表样 #

Calculation 工作表 #

Solution 工作表 #

原有代码 #

Sub cTotals()

Dim arr, arr2, arr3
Dim Calc As Worksheet: Set TS = Worksheets("Calculation")
Dim Sol As Worksheet: Set Sol = Worksheets("Solution")
Dim x As Long, i As Long, a As Long, c As Long, ct As Long
Dim GIVMM As Single, MSU As Double, Cases As Double
    
    
arr = Calc.Range("B2:H" & Cells(Rows.Count, 1).End(xlUp).Row)
arr2 = arr
With CreateObject("Scripting.Dictionary")
For x = LBound(arr) To UBound(arr)
    If Not IsMissing(arr(x, 1)) Then .Item(arr(x, 1)) = 1
Next
arr = .Keys
End With
ReDim arr3(1 To UBound(arr) + 1, 1 To 7)
c = 1: ct = 1
For i = 0 To UBound(arr)
    For a = 1 To UBound(arr2)
        If arr2(a, 1) = arr(i) Then
            arr3(i + 1, c) = arr(i)
            arr3(i + 1, c + 1) = ct
            ct = ct + 1
            GIVMM = GIVMM + arr2(a, 5)
            arr3(i + 1, c + 2) = GIVMM
            MSU = MSU + arr2(a, 6)
            arr3(i + 1, c + 3) = MSU
            Cases = Cases + arr2(a, 7)
            arr3(i + 1, c + 4) = Cases
        End If
    Next
    ct = 1: GIVMM = 0: MSU = 0: Cases = 0
Next
Sol.Range("B6").Resize(UBound(arr3, 1), UBound(arr3, 2)) = arr3

End Sub

原有代码存在3个问题：工作表对象赋值笔误、取数范围未明确指定父工作表（跨表运行时会取错范围）、客户列表从Calculation表去重生成不符合需求。

调整后可用代码 #

Sub cTotals()
    Dim arrCalc, arrSol, arrRes, j As Long
    Dim Calc As Worksheet, Sol As Worksheet
    Dim i As Long, lastRowCalc As Long, lastRowSol As Long
    Dim ct As Long, GIVMM As Single, MSU As Double, Cases As Double
    Const custCol As Long = 2, startRow As Long = 6 ' 客户编码在B列（列号2），数据从第6行开始
    
    ' 显式绑定工作表，任意工作表激活状态下运行都不会出现引用错误
    Set Calc = ThisWorkbook.Worksheets("Calculation")
    Set Sol = ThisWorkbook.Worksheets("Solution")
    
    ' 读取Calculation表全量有效数据
    lastRowCalc = Calc.Cells(Calc.Rows.Count, custCol).End(xlUp).Row
    arrCalc = Calc.Range("B2:H" & lastRowCalc).Value
    
    ' 读取Solution表现有客户列表
    lastRowSol = Sol.Cells(Sol.Rows.Count, custCol).End(xlUp).Row
    arrSol = Sol.Range("B" & startRow & ":B" & lastRowSol).Value
    
    ' 初始化结果数组，对齐原有输出结构
    ReDim arrRes(1 To UBound(arrSol, 1), 1 To 5)
    
    ' 遍历每个客户匹配统计
    For i = 1 To UBound(arrSol, 1)
        ct = 0: GIVMM = 0: MSU = 0: Cases = 0
        For j = 1 To UBound(arrCalc, 1)
            If arrCalc(j, 1) = arrSol(i, 1) Then
                ct = ct + 1
                GIVMM = GIVMM + arrCalc(j, 5)
                MSU = MSU + arrCalc(j, 6)
                Cases = Cases + arrCalc(j, 7)
            End If
        Next
        arrRes(i, 1) = arrSol(i, 1)
        arrRes(i, 2) = ct
        arrRes(i, 3) = GIVMM
        arrRes(i, 4) = MSU
        arrRes(i, 5) = Cases
    Next
    
    ' 结果输出到Solution表对应位置，保留原有客户列表
    Sol.Range("B" & startRow).Resize(UBound(arrRes, 1), UBound(arrRes, 2)) = arrRes
End Sub

使用说明 #

• 宏运行不依赖当前激活工作表，任意工作表下触发都能正常执行
• 统计基准为Solution工作表B列从第6行开始的已有客户编码，不会额外生成不存在的客户条目
• 统计规则与原逻辑一致：按客户编码匹配Calculation表数据，累计对应记录条数、GIVMM、MSU、Cases数值
• 结果直接填充到Solution表对应客户行，不覆盖原有客户列表
• 若客户编码列位置、数据起始行有变动，修改代码开头常量参数即可

内容的提问来源于stack exchange，提问作者Pea Ter