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

---