Edit code to fix out of stack space error

Certified

Board Regular
Joined
Jan 24, 2012
Messages
189
The code below used to work, but now I am getting an error (out of stack space).

The code calculates ownership percentages up an ownership tree.

For instance:
Company 11394 is owned 75% by 10528 and 25% by 50729.
Company 10528 is owned 25% by 37124, 25% by 21133 and 50% by 11488.
Company 50729 is owned 50% by 10210 and 25% by 23196 and 25% by and outside party.

Therefore the 11394's ownership % is 93.75% (25% * .75 of 50729 branch) + (100% of 10528 branch).

These calculations (branches of the tree) can run deep.

Now it seems like they may run too deep. My code is failing because of too many recursions.

My problem is I don't know how to fix it. Recursions was the only way I can get the code to work.

I was wondering if anyone has any suggestions or an alternative way to write it.

Thanks.


Code:
Public entities As New DictionaryPublic MainArray() As Variant


Const colEntity As Integer = 1   ' Assumed column A
Const colParent As Integer = 3   ' Assumed column C
Const colPct As Integer = 5      ' Assumed column E
Const colInside As Integer = 6   ' Assumed column F


Sub Calculepickup()


Dim wb As Workbook
Dim ws As Worksheet


    Sheet1.Activate


    Dim G As Integer, r As Integer, m As Integer
    Dim Mainrange As Range


    m = Cells(Rows.count, "A").End(xlUp).Row
    Set Mainrange = Range("a2:J" & m)
    MainArray() = Mainrange


    For G = 1 To UBound(MainArray, 1)
        If Not entities.Exists(MainArray(G, colEntity)) Then
            entities.Add MainArray(G, colEntity), -1
        End If
        If Not entities.Exists(MainArray(G, colParent)) Then
            If MainArray(G, colInside) = "No" Then
                'If the entity isn't "inside" store the fact that it is 0% owned
                entities.Add MainArray(G, colParent), 0
            Else
                entities.Add MainArray(G, colParent), -1
            End If
        End If
    Next


r = 2
    For Each e In entities.Keys


        CalculatePct e


    Next
    
    Range("n2").CurrentRegion.ClearComments
    
    Dim fm As Integer
    
        Cells(1, 14) = "GEMS ID"
        Cells(1, 15) = "Parent GEMS"
        Cells(1, 16) = "Pick-UP %"
    
    For fm = 1 To UBound(MainArray)
    
        
        Cells(fm + 1, 14) = MainArray(fm, 1)
        Cells(fm + 1, 15) = MainArray(fm, 2)
        Cells(fm + 1, 16) = Round((entities(MainArray(fm, 1)) * 100), 2)
    
    Next fm
    
    Cells(36, "g") = "Last updated: " & DateValue(Now) & " " & TimeValue(Now)
    
    Debug.Print "Done"


End Sub


        Sub CalculatePct(e As Variant)
            Dim G As Integer
            Dim pct As Double
            Dim Owned100Pct As Boolean
            If entities(e) < 0 Then
           
                pct = 0
                Owned100Pct = True
                
                For G = 1 To UBound(MainArray, 1)
                
                    If MainArray(G, colEntity) = e Then
                    
                        Owned100Pct = False
                        
                         If entities(MainArray(G, colParent)) = -1 Then
                           
                           
                        
                           [COLOR=#ff0000][B] CalculatePct MainArray(G, colParent)[/B][/COLOR]
                        
                        End If
                        
                        pct = pct + CDbl(MainArray(G, colPct)) / 100 * entities(MainArray(G, colParent))
                        
                    End If
                Next
        
                If Owned100Pct Then
                   
                    entities(e) = 1
                Else
                    'Store the entity's percentage
                    entities(e) = pct
                
                End If
            End If
        
        End Sub



 

Excel Facts

How can you turn a range sideways?
Copy the range. Select a blank cell. Right-click, Paste Special, then choose Transpose.
You have several variables declared as integers which can only be within -32,768 to 32,767

If they fall outside of these boundaries they will error. I haven't read all your code but that's where I'd start
 
Upvote 0
Just realised that the sub calls itself. Is this correct? It's rarely a good option
 
Upvote 0

Forum statistics

Threads
1,214,834
Messages
6,121,876
Members
449,056
Latest member
ruhulaminappu

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