计算拾取%所有权链的VBA代码

Question

第一次海报！

我希望有人能帮助我的VBA代码。我有一些VBA编码的经验，但我没有足够的知识或专业知识来处理我所面临的任务。

我有一份实体及其所有者的报告。

使用此报告，您可以跟踪每个实体的所有权链。

以下是报告的一个例子：

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

因此，基本上，实体1由实体2拥有100%，实体2由实体4和实体5拥有50%，实体3和实体4不属于任何附属公司。实体5按实体6拥有100%，实体6归实体7拥有25%，实体8拥有25%，实体9拥有50%。实体8按实体12拥有100%，实体9按实体10拥有25%，实体11拥有75%。实体10不是附属机构。

代码应该计算较低实体100 & 500的拾取%.在这种情况下，100的拾取%将是100%，因为链中的所有实体都是关联实体。而500的拾取%是75%，因为实体1000不是附属机构.

我已经开始并停止编写这段代码至少十次，每次我被困在路上。这是我的问题:在现实中，链可能上升7到8个水平。一旦我通过了二级，我不知道如何计算拾取%的实体有多个所有者。举个例子，如果你看我的桌子上面。一旦我计算了600的所有权，我想不出如何将这条链扩展到800和900的所有者。

以下是所有权结构的图表：

​

​

下面是我到目前为止掌握的代码：

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

我相信下面的人会做你想做的事。(这可能是将基于多个父母的“所有权百分比”与自己的“所有权百分比”联系起来的唯一真正方法。)

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