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

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 作为累积总数。
笔记:

这种方法不假设您的输入是有序的 - 因此可以处理无序的输入。

使用数组的优点是速度。使用数组比在循环中重复触摸工作表的开销要快得多。

需要图书馆引用:
需要通过 VBE > Tools > References 引用 Microsoft Scripting Runtime。请参阅最后解释如何的链接。

VBA:

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

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

想知道更多？
作为初学者，这里有一些有用的链接:

https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/dictionary-object

https://docs.microsoft.com/en-us/office/vba/language/concepts/getting-started/using-arrays

https://docs.microsoft.com/en-us/office/vba/language/how-to/check-or-add-an-object-library-reference