I have the data below in which column A contains a formula to pull the below data from another sheet, such that if the original sheet is modified, the values are updated.
For each group of metals I wish to create a sub total of the values as shown.
I appreciate that excel has a subtotal function, however when I try to achieve this I get an Error saying that the array cannot be altered. Is there any way to incorporate this into a dynamic array?
Possible VBA solution? Online I found the following VBA code which somewhat produced the desired affect I'm after however just as before this only works on pure data and will returns the same error "cannot amend array" if I apply this to pulled data.
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
As someone completely unfamiliar with VBA I'm not sure how helpful this is code is when applied to a dynamic array.
If anyone could think of a way to achieve the desired output as shown in the image above either using VBA or even better by amending the formula that creates the dynamic array (not sure if this is possible with just formulas), It would be appreciated.
Subtotals are calculated with a summary function, such as Sum or Average, by using the SUBTOTAL function. You can display more than one type of summary function for each column. Grand totals are derived from detail data, not from the values in the subtotals.
Short solution description:
You could do the whole thing with a couple of arrays and a dictionary. Use the dictionary to group by element, and then have an array for the associated value. The array would have 1D as concatenation of values encountered so far for that element (with a delimiter to later split on), 2D as being the cumulative total.
Note:
Library reference needed:
Requires a reference to Microsoft Scripting Runtime via VBE > Tools > References. See link that explains how at end.
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
Side note:
It may be possible that it is more efficient to update items within the array associated with each key as follows:
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
I will need to test when I have more time.
Want to know more?
As a beginner, here are some useful links:
If you don't mind your array to be in ascending order ("Lead" before "Mercury") and since you have Microsoft365, you can alter the array by formula, though not very pretty:
Formula in 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))
Without 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))
Furthermore I have added conditional formatting to column D:E
based on the following formula:
=$D1="Total"
Maybe someone can come up with something prettier and more efficient since there will be limits to CONCAT()
I suppose. Also, my version of 365 supports LET()
which, in this situation, is very handy.
Hopefully I didn't make any mistakes in translating this from Dutch to English.
Range.Subtotal method
Subtotal
compared to using dictionaries with arrays (my personal favorite) or whatever you can think of, doesn't make it less complicated (if not even more).Subtotal
in this particular case (e.g. the first column has to be grouped). Its power is unleashed when using it in-place. If you step through the code and look at the changes in the worksheet, you will see what I mean.
"A2"
and "D2"
).The Code
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
If you love us? You can donate to us via Paypal or buy me a coffee so we can maintain and grow! Thank you!
Donate Us With