Calculating sub totals within a Dynamic array/Range

Question

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.

Answer 1

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:

1. This approach does NOT assume your input is ordered - so can handle unordered input.
2. The advantage of using arrays is the speed. It is much faster to work with arrays than to incur the overhead of repeatedly touching the sheet in a loop.

---

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:

1. https://learn.microsoft.com/en-us/office/vba/language/reference/user-interface-help/dictionary-object
2. https://learn.microsoft.com/en-us/office/vba/language/concepts/getting-started/using-arrays
3. https://learn.microsoft.com/en-us/office/vba/language/how-to/check-or-add-an-object-library-reference

---

Answer 2

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.

Answer 3

Utilizing the Range.Subtotal method

• This is more of an investigation than an answer. It should illustrate that in this case, using 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).
• The images illustrate the flexibility of the solution or rather the inflexibility of 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.

• Adjust the constants (probably "A2" and "D2").
• Only run the first procedure, the rest is being called.

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