VBA to sum parent/child hierarchy values based on given hierarchy level

[jahsquare]

Hi, I have data that looks like columns 1 and 2 of the following:

[TABLE="class: grid, width: 354"]
<tbody>[TR]
[TD]Level[/TD]
[TD]Value[/TD]
[TD]Tree Index[/TD]
[TD]Current Output[/TD]
[TD]Expected Output[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]1[/TD]
[TD]1[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]3[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]1[/TD]
[TD]1.1[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]2[/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD]1[/TD]
[TD]1.1.1[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]1[/TD]
[TD]2[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]6[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]1[/TD]
[TD]2.1[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]5[/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD]3[/TD]
[TD]2.1.1[/TD]
[TD="align: right"]3[/TD]
[TD="align: right"]3[/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD]0[/TD]
[TD]2.1.2[/TD]
[TD="align: right"]0[/TD]
[TD="align: right"]1[/TD]
[/TR]
[TR]
[TD]4[/TD]
[TD]1[/TD]
[TD]2.1.2.1[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]2[/TD]
[TD]3[/TD]
[TD="align: right"]2[/TD]
[TD="align: right"]4[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]1[/TD]
[TD]3.1[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD]0[/TD]
[TD]3.1.1[/TD]
[TD="align: right"]0[/TD]
[TD="align: right"]0[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]1[/TD]
[TD]3.2[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[/TR]
</tbody>[/TABLE]

The script below works to build column 3 as an index, and I am trying to build column 4 to match the expected values in column 5, where each output is the sum of its own Value plus all direct child values. Obviously I am missing something with that for/do nested loop, I just can't get my head around it. I have done a lot of searching on flattened hierarchies and nested data but and couldn't come up with an answer I could understand.

For each level it should scan downwards, summing Values until it reaches a level that is less than or equal to itself (indicating the end of that branch of the tree).

Also here is an array formula that works to build the expected output in column 5. I just can't use this because there are too many records, computer can't handle it...
=IFERROR(SUM(OFFSET(B2,,,MATCH(TRUE,A3:$A$14<=A2,0))),SUM(B2:$B$14))

Any help is much appreciated!

Sub CalculateHierarchy()


    Dim rLevels As Range, rLevel As Range, rVals As Range, rVal As Range
    Dim level As Integer, maxLevels As Integer, val As Integer, cur As Integer, i As Integer
    Dim h As String, j As Long, counts() As Integer


    Set rLevels = Range("A2:A" & Range("A1").End(xlDown).Row)
    maxLevels = WorksheetFunction.Max(rLevels)
    
    Set rVals = Range("B2:B" & Range("B1").End(xlDown).Row)
    
    ReDim counts(1 To maxLevels)
    
    cur = 1
    
    For Each rLevel In rLevels
    
        level = rLevel.Value
        If level > cur + 1 Then
            rLevel.Activate
            MsgBox "error at row " & rLevel.Row & " level increase by more than 1"
            Exit Sub
        End If


        h = ""
        counts(level) = counts(level) + 1
        For i = 1 To level
            h = h & "." & counts(i)
        Next
        h = Mid(h, 2)
        
        For i = level + 1 To UBound(counts)
            counts(i) = 0
        Next
        
        j = 0
        For Each rVal In rVals
            val = rLevel.Offset(, 1).Value
            Do Until j = level
                val = val + rLevel.Offset(, 1).Value
                j = j + 1
            Loop
        Next
        
        rLevel.Offset(, 2).Value = h
        rLevel.Offset(, 3).Value = val


        val = 0
        cur = level
        
    Next


End Sub

 

[jahsquare]

There was an upload flub, the csv file should be updated now.

 

[MickG]

Please provide new link to file, your present one causes a Crash.

 

[jahsquare]

Please provide new link to file, your present one causes a Crash.

Sorry about that, here's two links -

file as .csv: https://www.dropbox.com/s/p33ij4suo8yer4r/hierarchy-test-data-2018-05-15.csv?dl=0

file as .xlsx: https://www.dropbox.com/s/fkf2yubbh5q263p/hierarchy-test-data-2018-05-15.xlsx?dl=0

Let me know if you still have trouble with dropbox, I can get the data to you some other way. Thanks

 

[MickG]

Both links are not responding, perhaps you could try "Box.com"
Or post a reasonable amount of data in the thread.
If the array code is still not working you would perhaps be better the use the first code with:-
Application.Screenupdating = false (at the top)
and
Application.Screenupdating = true (at the bottom)

 

[jahsquare]

Both links are not responding, perhaps you could try "Box.com"
Or post a reasonable amount of data in the thread.
If the array code is still not working you would perhaps be better the use the first code with:-
Application.Screenupdating = false (at the top)
and
Application.Screenupdating = true (at the bottom)

I think it would be better to try the full data as the issue doesn't show in a small subset, I am able to open the dropbox links but it does force you to view the spreadsheet in a browser before offering option to download.. anyway here are new links from Box.com:

csv: https://app.box.com/s/i50l763aqpk6x7f82vzzol16zh4wx1et

xlsx: https://app.box.com/s/744nyrhkaj1og9y98rsb6zab7f2bvre3

 

[MickG]

Try this file with Code in CommandButton.
I've sorted the Array code and your file ran in about 4.5 secs
NB:- I was unsure what to do about the first row , so I have arranged for the code to insert a "1" in row 2 if it does not exist, then remove at end of code.
https://app.box.com/s/mnwcjqvexgw65ywbfqkew9t1qvfuptmm

 

[jahsquare]

Try this file with Code in CommandButton.
I've sorted the Array code and your file ran in about 4.5 secs
NB:- I was unsure what to do about the first row , so I have arranged for the code to insert a "1" in row 2 if it does not exist, then remove at end of code.
https://app.box.com/s/mnwcjqvexgw65ywbfqkew9t1qvfuptmm

Amazing, thank you! It takes about 9 sec on my machine.

 

[MickG]

You're very welcome