VBA code to calculate pick-up% up ownership chain - vba

Question

First time poster!
I am hoping someone can help with my a VBA code. I have some experience with VBA coding, but I don't have the knowledge or expertise to handle the task I am facing.
I have a report of entities and their owners.
With this report, you can follow the ownership chain of each entity.
Here is an example of the Report:
Entity #, Entity Name, Parent #, Parent Name, Owner % Inside
100 Entity 1 200 Entity2 100 Yes
200 Entity 2 300 Entity 3 50 Yes
200 Entity 2 400 Entity 4 50 Yes
500 Entity 5 600 Entity 6 100 Yes
600 Entity 6 700 Entity 7 25 Yes
600 Entity 6 800 Entity 8 25 Yes
600 Entity 6 900 Entity 9 50 Yes
800 Entity 8 1200 Entity 12 100 Yes
900 Entity 9 1000 Entity 10 25 No
900 Entity 9 1100 Entity 11 75 Yes
So basically, Entity one is owned 100% by Entity 2. Entity 2 is owned by 50% by Entity 4 and Entity 5. Entity 3 and 4 is not owned by any affiliates. Entity 5 is owned 100% by Entity 6. Entity 6 is owned 25% to Entity 7, 25% by entity 8 and 50% by entity 9 . Entity 8 is owned 100% by entity 12. Entity 9 is owned 25% by entity 10 and 75% by Entity 11. Entity 10 is not an affiliate.
The code should calculate the Pick-up % of the lower entity [100 & 500]. In this case, the Pick-up % for 100 will be 100% because all of the entities in the chain are affiliates. While the pick-up% for 500 is 75% because entity 1000 is not an affiliate.
I have started and stop writing this code at least ten times and each time I get stuck along the way. Here is my issue: In reality, the chain could go up 7 to 8 levels. Once I get back past level two, I do not know how to calculate the pickup % of the entity has multiple owners. For instance, if you look at my table up top. Once I calculate the ownership for 600, I can't figure how to extend the chain to owners of 800 and 900.
Here is a diagram of the ownership structures:
Here is the code I have so far:
Sub ownerinterest()
Sheets("Copyii").Activate
Set dict3 = New Dictionary
nRowCount = Cells(Rows.Count, "B").End(xlUp).Row
arowcount = Cells(Rows.Count, "AA").End(xlUp).Row
ReportArray = Range(Cells(1, "AA"), Cells(arowcount, "AB"))
For i = 2 To nRowCount
GemC = Left(Cells(i, "a"), 5)
ParentC = Cells(i, "d")
PctC = (Cells(i, "J") / 100)
OwnerC = Cells(i, "h")
EntityC = Cells(i, "b")
d = i
If (Not (dict3.Exists(GemC))) Then
Set GEMclass = New Gclass
dict3.Add GemC, GEMclass
dict3(GemC).e = EntityC
dict3(GemC).P = ParentC
dict3(GemC).O = OwnerC
dict3(GemC).Num = d
dict3(GemC).g = GemC
End If
Call countlevels
dict3(GemC).Pct = PctC
Next i
Call Calculepickup
End Sub
Sub countlevels()
For e = LBound(ReportArray, 1) To UBound(ReportArray, 1)
If GemC = ReportArray(e, 1) Then
If ReportArray(e, 2) > 1 Then
Pcount = ReportArray(e, 2)
PctC = 0
For f = 1 To Pcount
TPct = Cells(i + f - 1, "J")
PctC = TPct + PctC
Next f
Exit For
Else
PctC = PctC
Exit For
End If
End If
Next e
End Sub
Sub Calculepickup()
Dim g As Long, h As Integer, j As Integer, m As Integer
Dim NewGem As String
Dim Tpct2 As Double
Dim MainArray() As Variant
Dim MainRange As Range
m = Cells(Rows.Count, "A").End(xlUp).Row
Set MainRange = Range("a1:J" & m)
MainArray() = MainRange
For g = 0 To dict3.Count - 1
Set GEMclass = dict3.Items(g)
ReportGEM = GEMclass.P
GemC = GEMclass.g
PctC = GEMclass.Pct
Debug.Print GemC & "|" & ReportGEM & "|" & PctC
For h = 0 To dict3.Count - 1
If (dict3.Exists(ReportGEM)) Then
NewGem = ReportGEM
For j = LBound(ReportArray) To UBound(ReportArray)
If NewGem = ReportArray(j, 1) Then
If ReportArray(j, 2) > 1 Then
Pcount = 0
Pcount = ReportArray(j, 2)
Tpct2 = 0
Dim K As Integer
For K = LBound(MainArray, 1) To UBound(MainArray, 1)
Dim GEMk As String
GEMk = MainArray(K, 1)
If NewGem = GEMk Then
Debug.Print GEMk & "|" & K
For f = 1 To Pcount
TPct = Cells(K + f - 1, "J")
Debug.Print TPct
Tpct2 = TPct + Tpct2
Debug.Print Tpct2
Next f
Exit For
End If
Next K
End If
End If
Next j
End If
Next h
Next g
End Sub

Answer 1

I believe that the following will do what you want. (It's probably the only real way to associate an "ownership percentage" based on multiple parents each with their own "ownership percentage".)
Public entities As New Dictionary
Public MainArray() As Variant
'I have assumed that the table you posted in the question represented columns A to F of an Excel spreadsheet.
'Change the following constants so it suits your actual layout.
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 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
'Add each entity to a dictionary, and flag the percentage as uncalculated by setting it to -1
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 = 0
For Each e In entities.Keys
CalculatePct e
'Write results to columns N and O just so that we can see them
r = r + 1
Cells(r, 14) = e
Cells(r, 15) = entities(e)
Next
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 ' Keeps track if the entity exists in the table other than as a parent
For g = 1 To UBound(MainArray, 1)
If MainArray(g, colEntity) = e Then
Owned100Pct = False
If entities(MainArray(g, colParent)) = -1 Then
'If we don't know the parent's ownership percentage, go and calculate it
CalculatePct MainArray(g, colParent)
End If
pct = pct + CDbl(MainArray(g, colPct)) / 100 * entities(MainArray(g, colParent))
End If
Next
If Owned100Pct Then
'Assume 100% owned if we don't know the parentage
'("Outside" entities won't go through here as they are already set to 0%)
entities(e) = 1
Else
'Store the entity's percentage
entities(e) = pct
End If
End If
End Sub