计算动态数组/范围内的小计

Question

我有下面的数据，其中 A 列包含一个公式，用于从另一张工作表中提取以下数据，这样如果修改原始工作表，则更新值。

对于每组金属，我希望创建如图所示的值的小计。

我很欣赏 excel 有一个小计功能，但是当我尝试实现这一点时，我收到一个错误，指出无法更改数组。有没有办法将它合并到动态数组中？

可能的 VBA 解决方案？ 我在网上发现了以下 VBA 代码，它在某种程度上产生了我想要的效果，但是就像以前一样，这仅适用于纯数据，如果我将其应用于提取的数据，将返回相同的错误“无法修改数组”。

Sub ApplySubTotals()
   Dim lLastRow As Long
   
   With ActiveSheet
      lLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
      If lLastRow < 3 Then Exit Sub
      .Range("E5:M" & lLastRow).Subtotal GroupBy:=1, _
         Function:=xlSum, TotalList:=Array(1, 2), _
         Replace:=True, PageBreaks:=False, SummaryBelowData:=True
   End With
End Sub

作为完全不熟悉 VBA 的人，我不确定这段代码在应用于动态数组时有多大帮助。

如果有人能想出一种方法来实现如上图所示的所需输出，要么使用 VBA，要么通过修改创建动态数组的公式更好（不确定仅使用公式是否可行），我们将不胜感激。

Answer 1

简短的解决方案描述：

您可以使用几个数组和一个字典来完成整个事情。使用字典按元素分组，然后为关联值建立一个数组。该数组将 1D 作为该元素迄今为止遇到的值的串联（带有稍后拆分的分隔符），2D 作为累积总数。

笔记：

1. 这种方法并不假设您的输入是有序的 - 因此可以处理无序的输入。
2. 使用数组的优点是速度。使用数组比在循环中重复接触工作表要快得多。

需要的图书馆参考：

需要通过 VBE > 工具 > 引用引用 Microsoft 脚本运行时。请参阅最后解释如何操作的链接。

编程语言：

Option Explicit

Public Sub ApplySubTotals()
    Dim lastRow As Long
   
    With ActiveSheet
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        If lastRow < 4 Then Exit Sub
      
        Dim arr(), dict As Scripting.Dictionary, i As Long
     
        arr = .Range("A4:B" & lastRow).Value
        Set dict = New Scripting.Dictionary
      
        For i = LBound(arr, 1) To UBound(arr, 1)
            If Not dict.Exists(arr(i, 1)) Then
                dict(arr(i, 1)) = Array(arr(i, 2), arr(i, 2))
            Else
                dict(arr(i, 1)) = Array(dict(arr(i, 1))(0) & ";" & arr(i, 2), dict(arr(i, 1))(1) + arr(i, 2))
            End If
        Next
 
        ReDim arr(1 To lastRow + dict.Count - 3, 1 To 2)
        Dim key As Variant, r As Long, arr2() As String
      
        For Each key In dict.Keys
            arr2 = Split(dict(key)(0), ";")
            For i = LBound(arr2) To UBound(arr2)
                r = r + 1
                arr(r, 1) = key
                arr(r, 2) = arr2(i)
            Next
            r = r + 1
            arr(r, 1) = "Subtotal": arr(r, 2) = dict(key)(1)
        Next
        .Cells(4, 4).Resize(UBound(arr, 1), UBound(arr, 2)) = arr
    End With
End Sub

边注：

更新与每个键关联的数组中的项目可能会更有效，如下所示：

If Not dict.Exists(arr(i, 1)) Then
    dict(arr(i, 1)) = Array(arr(i, 2), arr(i, 2))
Else
    dict(arr(i, 1))(0) = dict(arr(i, 1))(0) & ";" & arr(i, 2)
    dict(arr(i, 1))(1) = dict(arr(i, 1))(1) + arr(i, 2)
End If

当我有更多时间时，我需要进行测试。

想知道更多？

作为初学者，这里有一些有用的链接：

1. https://learn.microsoft.com/en-us/office/vba/language/reference/user-interface-help/dictionary-object
2. https://learn.microsoft.com/en-us/office/vba/language/concepts/getting-started/using-arrays
3. https://learn.microsoft.com/en-us/office/vba/language/how-to/check-or-add-an-object-library-reference