计算动态 array/Range 中的小计
Calculating sub totals within a Dynamic array/Range
我有下面的数据，其中 A 列包含一个公式，可以从另一个 sheet 中提取下面的数据，这样，如果原始 sheet 被修改，值就会更新。
对于每组金属，我希望创建如图所示的值的小计。
我很欣赏 excel 具有小计功能，但是当我尝试实现此功能时，我收到一条错误消息，指出无法更改数组。有什么方法可以将其合并到动态数组中吗？
可能的 VBA 解决方案？
在网上，我发现以下 VBA 代码在某种程度上产生了我想要的效果，但是就像以前一样，这只适用于纯数据，如果我应用它，将 returns 出现相同的错误“无法修改数组”拉取数据。
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 或通过修改创建动态数组的公式来更好（不确定这是否可行只是公式），我们将不胜感激。
你不能通过这种方式改变数组。 VBA 数组在某种程度上是固定的。如果您需要更改数组，那么您需要使用循环并每次都重置数组的维度。寻找 'redim preserve array()'.
简短的解决方案描述：
你可以用几个数组和一个字典来完成整个事情。使用字典按元素分组，然后为关联值创建一个数组。该数组将 1D 作为该元素到目前为止遇到的值的串联（带有稍后拆分的分隔符），2D 作为累积总数。
注：
- 此方法不假定您的输入是有序的 - 因此可以处理无序输入。
- 使用数组的优势在于速度。使用数组比在循环中重复触摸 sheet 带来的开销要快得多。
需要参考资料库：
需要通过 VBE > 工具 > 引用引用 Microsoft Scripting Runtime。请参阅 link 解释最后的方法。
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
等我有时间再去测试。
想了解更多？
作为初学者，这里有一些有用的links:
- 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
如果您是 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#,,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()，在这种情况下，非常好用。
希望我在将其从荷兰语翻译成英语时没有犯任何错误。
我有下面的数据，其中 A 列包含一个公式，可以从另一个 sheet 中提取下面的数据，这样，如果原始 sheet 被修改，值就会更新。
对于每组金属，我希望创建如图所示的值的小计。
我很欣赏 excel 具有小计功能，但是当我尝试实现此功能时，我收到一条错误消息，指出无法更改数组。有什么方法可以将其合并到动态数组中吗？
可能的 VBA 解决方案？ 在网上，我发现以下 VBA 代码在某种程度上产生了我想要的效果，但是就像以前一样，这只适用于纯数据，如果我应用它，将 returns 出现相同的错误“无法修改数组”拉取数据。
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 或通过修改创建动态数组的公式来更好（不确定这是否可行只是公式），我们将不胜感激。
你不能通过这种方式改变数组。 VBA 数组在某种程度上是固定的。如果您需要更改数组，那么您需要使用循环并每次都重置数组的维度。寻找 'redim preserve array()'.
简短的解决方案描述：
你可以用几个数组和一个字典来完成整个事情。使用字典按元素分组，然后为关联值创建一个数组。该数组将 1D 作为该元素到目前为止遇到的值的串联（带有稍后拆分的分隔符），2D 作为累积总数。
注：
- 此方法不假定您的输入是有序的 - 因此可以处理无序输入。
- 使用数组的优势在于速度。使用数组比在循环中重复触摸 sheet 带来的开销要快得多。
需要参考资料库：
需要通过 VBE > 工具 > 引用引用 Microsoft Scripting Runtime。请参阅 link 解释最后的方法。
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
等我有时间再去测试。
想了解更多？
作为初学者，这里有一些有用的links:
- 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
如果您是 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#,,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()，在这种情况下，非常好用。
希望我在将其从荷兰语翻译成英语时没有犯任何错误。