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

问题描述

我有下面的数据，其中 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，要么通过修改创建动态数组的公式更好（不确定仅使用公式是否可行），它会不胜感激。

解决方法

简短的解决方案说明：

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

注意：

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

需要图书馆参考：

需要通过 VBE > 工具 > 引用引用 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,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,2))
Else
    dict(arr(i,1))(0) = dict(arr(i,2)
    dict(arr(i,1))(1) = dict(arr(i,2)
End If

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

想了解更多？

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

如果您是 completely unfamiliar with VBA，您可能会发现使用字典和数组的前景有些令人生畏。因此，我在下面提供了一个更简单的替代方案，希望您可以更轻松地遵循。它假定您的数据布局与上面显示的完全一样，并且您的数据已排序。

Option Explicit
Sub InsertSubTotals()
Dim LastRow As Long,i As Long,c As Range,ws As Worksheet
Set ws = ActiveSheet   
Application.ScreenUpdating = False

'Clear existing data from columns D:E
LastRow = ws.Cells(Rows.Count,4).End(xlUp).Row
If LastRow = 3 Then LastRow = 4
ws.Range("D4:E" & LastRow).Clear

'Copy the data from A:B to D:E
LastRow = ws.Cells(Rows.Count,1).End(xlUp).Row
ws.Range("A4:B" & LastRow).Copy ws.Range("D4")
       
'Insert cells for the subtotals
For i = LastRow To 5 Step -1
    If ws.Cells(i,4) <> ws.Cells(i - 1,4) Then
        ws.Range(ws.Cells(i,4),ws.Cells(i,5)).Insert xlShiftDown
    End If
Next i

'Insert formulas,"Total" and format bold
LastRow = ws.Cells(Rows.Count,4).End(xlUp).Row + 1
For Each c In ws.Range("D5:D" & LastRow)
    If c = "" Then
        With c
            .Offset(,1).FormulaR1C1 = "=sumif(C4,R[-1]C4,C5)"
            .Value = "Total"
            ws.Range(c,c.Offset(,1)).Font.Bold = True
        End With
    End If
Next c  
End Sub

利用 `Range.Subtotal method`

这与其说是答案，不如说是调查。它应该说明，在这种情况下，使用 Subtotal 与使用带有数组的字典（我个人最喜欢的）或您能想到的任何东西相比，并不会让它变得更简单（如果不是更复杂）。
这些图像说明了解决方案的灵活性，或者更确切地说是 Subtotal 在这种特殊情况下的不灵活性（例如，必须对第一列进行分组）。当就地使用时，它的力量就会释放出来。如果您单步执行代码并查看工作表中的更改，您就会明白我的意思。

调整常量（可能是 "A2" 和 "D2"）。
只运行第一个过程，其余的正在被调用。

代码

Option Explicit

Sub createTotalsReport()
    
    Const sFirst As String = "C6"
    Const dFirst As String = "F2"
    
    Dim sCell As Range: Set sCell = ActiveSheet.Range(sFirst)
    Dim dCell As Range: Set dCell = ActiveSheet.Range(dFirst)
    
    Dim rg As Range: Set rg = refCurrentRegionBottomRight(sCell)
    
    Application.ScreenUpdating = False
    rg.Subtotal GroupBy:=1,Function:=xlSum,TotalList:=Array(2),_
        Replace:=True,PageBreaks:=False,SummaryBelowData:=True
    Set rg = refCurrentRegionBottomRight(sCell)
    Dim Data As Variant: Data = getRange(rg)
    rg.RemoveSubtotal
    Dim Successful As Boolean: Successful = writeData(dCell,Data)
    ' Or just...
    'writeData Range(dFirst),Data
    ' and remove the rest.
    Application.ScreenUpdating = True
    
    If Successful Then
        MsgBox "Totals range created.",vbInformation,"Success"
    Else
        MsgBox "Something went wrong.",vbCritical,"Fail?"
    End If

End Sub

' Purpose:      Returns a reference to the range starting with a given cell
'               and ending with the last cell of its Current Region.
Function refCurrentRegionBottomRight( _
    ByVal FirstCellRange As Range) _
As Range
    If Not FirstCellRange Is Nothing Then
        With FirstCellRange.CurrentRegion
            Set refCurrentRegionBottomRight = _
                FirstCellRange.Resize(.Row + .Rows.Count - FirstCellRange.Row,_
                .Column + .Columns.Count - FirstCellRange.Column)
        End With
    End If
End Function

' Purpose:      Returns the values of a given range in a 2D one-based array.
Function getRange( _
    ByVal rg As Range) _
As Variant
    Dim Data As Variant
    If Not rg Is Nothing Then
        If rg.Rows.Count > 1 Or rg.Columns.Count > 1 Then
            Data = rg.Value
        Else
            ReDim Data(1 To 1,1 To 1): Data(1,1) = rg.Value
        End If
        getRange = Data
    End If
End Function

' Purpose:      Writes the values from a given 2D one-based array to a range
'               defined by its given first cell (range) and the size
'               of the array. Optionally (by default),clears the contents
'               of the cells below the resulting range.
Function writeData( _
    ByVal FirstCellRange As Range,_
    ByVal Data As Variant,_
    Optional ByVal doClearContents As Boolean = True) _
As Boolean
    If Not FirstCellRange Is Nothing Then
        Dim rCount As Long: rCount = UBound(Data,1)
        With FirstCellRange.Resize(,UBound(Data,2))
            .Resize(rCount).Value = Data
            If doClearContents Then
                .Resize(.Worksheet.Rows.Count - .Row - rCount + 1) _
                    .Offset(rCount).ClearContents
            End If
            writeData = True
        End With
    End If
End Function

如果你不介意你的数组按升序排列（“Mercury”之前的“Lead”）并且因为你有 Microsoft365，你可以通过公式改变数组，虽然不是很漂亮：

D4 中的公式：

=CHOOSE({1,2},LET(Z,FILTERXML("<t><s>"&CONCAT(LET(A,SORT(UNIQUE(INDEX(A4#,1))),REPT(A&"</s><s>",COUNTIF(INDEX(A4#,A)))&"Total"&"</s><s>")&"</s></t>","//s"),FILTER(Z,NOT(ISERROR(Z)))),INDEX(LET(Y,CHOOSE({1,FILTERXML("<t><s>"&TEXTJOIN("</s><s>",INDEX(A4#,UNIQUE(INDEX(A4#,1)))&"</s></t>",SUMIFS(INDEX(A4#,1))))&"</s></t>","//s")),SORTBY(Y,INDEX(Y,2))

没有LET()：

=CHOOSE({1,FILTER(FILTERXML("<t><s>"&CONCAT(REPT(SORT(UNIQUE(INDEX(A4#,1)))&"</s><s>",1)))))&"Total"&"</s><s>")&"</s></t>",NOT(ISERROR(FILTERXML("<t><s>"&CONCAT(REPT(SORT(UNIQUE(INDEX(A4#,"//s")))),INDEX(SORTBY(CHOOSE({1,INDEX(CHOOSE({1,1)),2))

此外，我根据以下公式向列 D:E 添加了条件格式：

=$D1="Total"

也许有人可以想出更漂亮、更有效的方法，因为我想 CONCAT() 会有限制。此外，我的 365 版本支持 LET()，这在这种情况下非常方便。

希望我在从荷兰语翻译成英语时没有犯任何错误。

您不能以这种方式更改数组。 VBA 数组在某种程度上是固定的。如果您需要更改数组，那么您需要使用循环并每次都重置数组的维度。寻找“redim 保留数组（）”。

dynamic-arrays excel excel excel-365 excel-formula vba

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

问题描述

解决方法

利用 Range.Subtotal method

利用 `Range.Subtotal method`