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

jahsquare

Board Regular
Joined
Jan 22, 2014
Messages
51
Hi, I have data that looks like columns 1 and 2 of the following:

LevelValueTree IndexCurrent OutputExpected Output
11113
211.112
311.1.111
11216
212.115
332.1.133
302.1.201
412.1.2.111
12324
213.111
303.1.100
213.211

<tbody>
</tbody>

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!

Code:
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
 
Last edited:

Excel Facts

Difference between two dates
Secret function! Use =DATEDIF(A2,B2,"Y")&" years"&=DATEDIF(A2,B2,"YM")&" months"&=DATEDIF(A2,B2,"MD")&" days"
Upvote 0
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)
 
Last edited:
Upvote 0
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
 
Upvote 0

Forum statistics

Threads
1,216,030
Messages
6,128,413
Members
449,449
Latest member
Quiet_Nectarine_

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top