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.

JvdV · Answer 1 · 2021-02-22T11:31:59.623

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.

Let us [continue this discussion in chat](https://chat.stackoverflow.com/rooms/229037/discussion-between-jvdv-and-nick). — JvdV, Feb 22 '21 at 12:42
@Nick, since you have not given any further feedback, can I delete this answer? — JvdV, Mar 04 '21 at 13:48

QHarr · Accepted Answer · 2021-02-22T13:24:03.843

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:

This approach does NOT assume your input is ordered - so can handle unordered input.
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:

How could I modify this to account for an array between columns A and F? A is the Element column as before but compared to this simplified example, in reality pulls the data for columns B-C. Where C acts as a base value to calculate the level of metals at different ages through columns D to. I would like to be able to total each of these, splitting this array as before just as your VBA code does but for more values. I have tried to modify your code but keep running into little errors. — Nick, Feb 22 '21 at 17:29
Sorry, you will need to run that by me slowly. There's nearly always a way with VBA, I just need to understand the requirement and what the revised data looks like. Also, tip for the future, whilst it is good to make a question as simple as possible don't take it too far from the use case :-) — QHarr, Feb 22 '21 at 18:48
Hi Yes of course would you mind joining this chat? https://chat.stackoverflow.com/rooms/229055/room-for-nick-and-qharr — Nick, Feb 22 '21 at 20:17

score 1 · Answer 3 · 2021-02-22T20:23:39.310

If you are completely unfamiliar with VBA, you may find the prospect of using dictionaries and arrays somewhat daunting. As such, I've provided a simpler alternative below that you can hopefully follow more easily. It assumes your data layout is exactly as you show it above, and that your data is sorted.

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

VBasic2008 · Answer 4 · 2021-02-22T18:57:05.290

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

Hound · Answer 5 · 2021-02-22T04:09:32.963

0

you can not alter an array thay way. VBA arrays are fixed in a way. if you need to alter array then you need to use a loop and reset the dimension of the array everytime. look for 'redim preserve array()'.

edited Feb 22 '21 at 04:09

answered Feb 22 '21 at 01:14

Hound

1
3

Calculating sub totals within a Dynamic array/Range

5 Answers5

Utilizing the `Range.Subtotal method`

Linked

Calculating sub totals within a Dynamic array/Range

5 Answers5

Utilizing the Range.Subtotal method

Linked

Utilizing the `Range.Subtotal method`