5

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

4

5 回答 5

1

利用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
于 2021-02-22T08:43:50.970 回答
1

简短的解决方案描述：

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

笔记：

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

需要图书馆参考：

需要通过 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

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

想知道更多？

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

  1. https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/dictionary-object
  2. https://docs.microsoft.com/en-us/office/vba/language/concepts/getting-started/using-arrays
  3. https://docs.microsoft.com/en-us/office/vba/language/how-to/check-or-add-an-object-library-reference
于 2021-02-22T01:56:12.117 回答
1

如果您不介意数组按升序排列（“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#,,1),A)))&"Total"&"</s><s>")&"</s></t>","//s"),FILTER(Z,NOT(ISERROR(Z)))),INDEX(LET(Y,CHOOSE({1,2},FILTERXML("<t><s>"&TEXTJOIN("</s><s>",,INDEX(A4#,,1),UNIQUE(INDEX(A4#,,1)))&"</s></t>","//s"),FILTERXML("<t><s>"&TEXTJOIN("</s><s>",,INDEX(A4#,,2),SUMIFS(INDEX(A4#,,2),INDEX(A4#,,1),UNIQUE(INDEX(A4#,,1))))&"</s></t>","//s")),SORTBY(Y,INDEX(Y,,1))),,2))

没有LET()：

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

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

=$D1="Total"

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

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

于 2021-02-22T08:50:23.270 回答
1

如果您是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
于 2021-02-22T04:38:30.137 回答
0

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

于 2021-02-22T01:14:17.807 回答