Excel VBA实验室分析工作簿SUBTOTAL函数数据计算错误排查

阿华AIGC实验室

2026-6-12

实验室分析工作簿计算错误及功能完善方案

场景说明

涉及两个工作表：Raw Data和Summary Data
- Raw Data工作表的RawData表存储基础数据，示例：
  Column A Column B
  1 2
  2 3
- Summary Data工作表的SummaryData表第一列为Variables，对应RawData的所有表头；点击"EDIT FUNCTIONS"按钮打开用户窗体，选择11种SUBTOTAL()函数之一（如Average），SummaryData的表头会同步更新为所选函数。

Column A	Column B
1	2
2	3

问题现象

函数调用逻辑正常，但计算结果错误：所有Variables行均重复RawData最后一列的计算值。例如Column A的平均值应为1.5，却显示为2.5（与Column B的平均值一致），正确结果应为：

Variables	Average
Column A	1.5
Column B	2.5

代码问题及额外需求

已编写完整VBA模块及用户窗体代码，但ApplyAllFunctionValues未被调用，无法解决计算错误；
需要实现：当RawData表收缩（列/行数量减少）时，自动删除SummaryData中多余的数据。

问题根源及修复方案

1. 计算错误修复

错误原因：FillFunctionValue中构建公式时，错误地将VBA变量RawRangeAddress通过INDIRECT引用，导致所有单元格公式都使用该变量的最终值（最后一列的地址）。

修复代码：将公式中的INDIRECT调用替换为直接嵌入地址：

' 原代码
TargetCell.Formula = "=SUBTOTAL(" & FuncCode & ", INDIRECT("""" & RawRangeAddress & """"))"

' 修改后
TargetCell.Formula = "=SUBTOTAL(" & FuncCode & ", " & RawRangeAddress & ")"

2. 自动触发计算

在GiveFunctions过程末尾添加ApplyAllFunctionValues调用，确保选择函数后自动计算所有值：

' 在GiveFunctions的最后一行添加
ApplyAllFunctionValues

3. RawData收缩时自动清理SummaryData

修改GetHeaders过程，添加删除多余变量行的逻辑，并在RawData表结构变化时触发同步：

修改后的`GetHeaders`过程

Public Sub GetHeaders()
    Dim RawTbl As ListObject
    Dim summaryTbl As ListObject
    Dim col As Range
    Dim destCell As Range
    Dim wsSummary As Worksheet
    Dim wsRaw As Worksheet
    Dim headerList As Collection
    Dim varExists As Boolean
    Dim i As Long

    Set wsRaw = Sheets("Raw Data")
    Set RawTbl = wsRaw.ListObjects("RawData")
    Set wsSummary = Sheets("Summary Data")
    Set summaryTbl = wsSummary.ListObjects("SummaryData")

    ' 收集RawData的有效表头（去重）
    Set headerList = New Collection
    On Error Resume Next
    For Each col In RawTbl.HeaderRowRange.Cells
        If Trim(col.Value) <> "" Then
            headerList.Add col.Value, Key:=UCase(Trim(col.Value))
        End If
    Next col
    On Error GoTo 0

    With summaryTbl
        ' 删除SummaryData中不在RawData表头里的变量行
        If Not .DataBodyRange Is Nothing Then
            For i = .ListRows.Count To 1 Step -1
                varExists = False
                For Each col In headerList
                    If UCase(Trim(.ListRows(i).Range.Cells(1).Value)) = UCase(Trim(col)) Then
                        varExists = True
                        Exit For
                    End If
                Next col
                If Not varExists Then
                    .ListRows(i).Delete
                End If
            Next i
        End If

        ' 清空现有变量列内容
        If Not .ListColumns(1).DataBodyRange Is Nothing Then
            .ListColumns(1).DataBodyRange.ClearContents
        End If

        ' 调整行数以匹配表头数量
        If .DataBodyRange Is Nothing Then
            .ListRows.Add
        End If
        If .DataBodyRange.Rows.Count <> headerList.Count Then
            .Resize .HeaderRowRange.Resize(1 + headerList.Count)
        End If

        ' 填充变量名称
        Set destCell = .DataBodyRange.Cells(1, 1)
        For i = 1 To headerList.Count
            destCell.Value = headerList(i)
            Set destCell = destCell.Offset(1, 0)
        Next i
    End With

    ' 同步计算所有函数值
    ApplyAllFunctionValues
End Sub

添加RawData工作表事件

打开Raw Data工作表的代码模块（右键工作表标签→查看代码），粘贴以下代码，实现表结构变化时自动同步：

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim RawTbl As ListObject
    Set RawTbl = Me.ListObjects("RawData")
    ' 当RawData的表头或数据区域变化时同步SummaryData
    If Not Intersect(Target, RawTbl.HeaderRowRange) Is Nothing Or _
       Not Intersect(Target, RawTbl.DataBodyRange) Is Nothing Then
        GetHeaders
    End If
End Sub

Private Sub Worksheet_Deactivate()
    ' 切换工作表时同步数据，确保一致性
    GetHeaders
End Sub

完整修复后的代码

VBA模块代码

Public SelectedFunctions() As String
Public PreviousHeaders() As String

Public Sub FillFunctionValue(VarName As String, FuncName As String, TargetCell As Range)
    Dim RawTbl As ListObject
    Set RawTbl = ThisWorkbook.Sheets("Raw Data").ListObjects("RawData")

    ' Step 1: Map function name to subtotal code
    Dim FuncCodeMap As Object
    Set FuncCodeMap = CreateObject("Scripting.Dictionary")

    FuncCodeMap.Add "Average", 101
    FuncCodeMap.Add "Count", 102
    FuncCodeMap.Add "CountA", 103
    FuncCodeMap.Add "Max", 104
    FuncCodeMap.Add "Min", 105
    FuncCodeMap.Add "Product", 106
    FuncCodeMap.Add "StDev", 107
    FuncCodeMap.Add "StDevP", 108
    FuncCodeMap.Add "Sum", 109
    FuncCodeMap.Add "Var", 110
    FuncCodeMap.Add "VarP", 111

    If Not FuncCodeMap.exists(FuncName) Then Exit Sub
    Dim FuncCode As Integer
    FuncCode = FuncCodeMap(FuncName)

    ' Step 2: Find the column in RawData that matches the variable name
    Dim i As Long
    Dim RawColIndex As Long
    RawColIndex = -1

    For i = 1 To RawTbl.ListColumns.Count
        If Trim(RawTbl.HeaderRowRange.Cells(1, i).Value) = Trim(VarName) Then
            RawColIndex = i
            Exit For
        End If
    Next i

    If RawColIndex = -1 Then
        TargetCell.Value = "Var not found"
        Exit Sub
    End If

    ' Step 3: Build the formula and write it to the cell
    Dim RawRangeAddress As String
    RawRangeAddress = "'" & RawTbl.Parent.Name & "'!" & _
        RawTbl.ListColumns(RawColIndex).DataBodyRange.Address(False, False)

    ' 修复：直接嵌入地址，不再使用INDIRECT引用VBA变量
    TargetCell.Formula = "=SUBTOTAL(" & FuncCode & ", " & RawRangeAddress & ")"
End Sub

Public Sub ApplyAllFunctionValues()
    Dim ws As Worksheet
    Dim tbl As ListObject
    Set ws = ThisWorkbook.Sheets("Summary Data")
    Set tbl = ws.ListObjects("SummaryData")
    
    Dim r As Long, c As Long
    Dim VarName As String
    Dim FuncName As String
    Dim TargetCell As Range

    ' 检查表是否有数据行
    If tbl.DataBodyRange Is Nothing Then Exit Sub

    For r = 1 To tbl.ListRows.Count
        VarName = tbl.DataBodyRange.Cells(r, 1).Value ' Column 1 is variable name
        For c = 2 To tbl.ListColumns.Count
            FuncName = tbl.HeaderRowRange.Cells(1, c).Value
            Set TargetCell = tbl.DataBodyRange.Cells(r, c)
            Call FillFunctionValue(VarName, FuncName, TargetCell)
        Next c
    Next r
End Sub

Function IsArrayInitialized(arr As Variant) As Boolean
    On Error Resume Next
    IsArrayInitialized = IsArray(arr) And Not IsError(LBound(arr)) And LBound(arr) <= UBound(arr)
    On Error GoTo 0
End Function

Public Sub GetFunctions()
    EditFunctions.Show
End Sub

Public Sub GiveFunctions()
    Dim tbl As ListObject
    Set tbl = Sheets("Summary Data").ListObjects("SummaryData")
    Dim i As Integer
    For i = 2 To tbl.HeaderRowRange.Columns.Count
        tbl.HeaderRowRange.Cells(1, i).Value = ""
    Next i
    Dim fIndex As Integer
    For fIndex = 0 To UBound(SelectedFunctions)
        tbl.HeaderRowRange.Cells(1, fIndex + 2).Value = SelectedFunctions(fIndex)
    Next fIndex
    
    Dim colIndex As Integer
    
    For colIndex = tbl.ListColumns.Count To 2 Step -1
        Dim ColName As String
        ColName = tbl.HeaderRowRange.Cells(1, colIndex).Value

        Dim found As Boolean
        found = False
    
        For i = LBound(SelectedFunctions) To UBound(SelectedFunctions)
            If SelectedFunctions(i) = ColName Then
                found = True
            Exit For
        End If
    Next i

        If Not found Then
            tbl.ListColumns(colIndex).Delete
        End If
    Next colIndex
    
    Dim col As ListColumn
    For Each col In tbl.ListColumns
        With col.Range
            .Columns.AutoFit
            .ColumnWidth = .ColumnWidth + 8
        End With
    Next col
    
    ' 新增：选择函数后自动计算所有值
    ApplyAllFunctionValues
End Sub

Public Sub GetHeaders()
    Dim RawTbl As ListObject
    Dim summaryTbl As ListObject
    Dim col As Range
    Dim destCell As Range
    Dim wsSummary As Worksheet
    Dim wsRaw As Worksheet
    Dim headerList As Collection
    Dim varExists As Boolean
    Dim i As Long

    Set wsRaw = Sheets("Raw Data")
    Set RawTbl = wsRaw.ListObjects("RawData")
    Set wsSummary = Sheets("Summary Data")
    Set summaryTbl = wsSummary.ListObjects("SummaryData")

    ' 收集RawData的有效表头（去重）
    Set headerList = New Collection
    On Error Resume Next
    For Each col In RawTbl.HeaderRowRange.Cells
        If Trim(col.Value) <> "" Then
            headerList.Add col.Value, Key:=UCase(Trim(col.Value))
        End If
    Next col
    On Error GoTo 0

    With summaryTbl
        ' 删除SummaryData中不在RawData表头里的变量行
        If Not .DataBodyRange Is Nothing Then
            For i = .ListRows.Count To 1 Step -1
                varExists = False
                For Each col In headerList
                    If UCase(Trim(.ListRows(i).Range.Cells(1).Value)) = UCase(Trim(col)) Then
                        varExists = True
                        Exit For
                    End If
                Next col
                If Not varExists Then
                    .ListRows(i).Delete
                End If
            Next i
        End If

        ' 清空现有变量列内容
        If Not .ListColumns(1).DataBodyRange Is Nothing Then
            .ListColumns(1).DataBodyRange.ClearContents
        End If

        ' 调整行数以匹配表头数量
        If .DataBodyRange Is Nothing Then
            .ListRows.Add
        End If
        If .DataBodyRange.Rows.Count <> headerList.Count Then
            .Resize .HeaderRowRange.Resize(1 + headerList.Count)
        End If

        ' 填充变量名称
        Set destCell = .DataBodyRange.Cells(1, 1)
        For i = 1 To headerList.Count
            destCell.Value = headerList(i)
            Set destCell = destCell.Offset(1, 0)
        Next i
    End With

    ' 同步计算所有函数值
    ApplyAllFunctionValues
End Sub

用户窗体代码

Private Sub btnOK_Click()
    Dim FuncList As Variant
    FuncList = Array("Average", "Count", "CountA", "Max", "Min", "Product", "StDev", "StDevP", "Sum", "Var", "VarP")
    Dim i As Integer
    Dim SelectedCount As Integer
    SelectedCount = 0
    For i = LBound(FuncList) To UBound(FuncList)
        If Me.Controls(FuncList(i)).Value = True Then
            SelectedCount = SelectedCount + 1
        End If
    Next i
    If SelectedCount = 0 Then
        MsgBox "You must select at least one function.", vbExclamation
        Exit Sub
    End If
    ReDim SelectedFunctions(0 To SelectedCount - 1)
    Dim j As Integer
    j = 0
    
    For i = LBound(FuncList) To UBound(FuncList)
        If Me.Controls(FuncList(i)).Value = True Then
            SelectedFunctions(j) = FuncList(i)
            j = j + 1
        End If
    Next i
    
    Unload Me
    GiveFunctions
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If CloseMode = vbFormControlMenu Then
        Cancel = True
    End If
End Sub

内容的提问来源于stack exchange，提问作者Rajan Hill