用于计算提货%所有权链的VBA代码_Vba_Excel

用于计算提货%所有权链的VBA代码

vba excel

用于计算提货%所有权链的VBA代码,vba,excel,Vba,Excel,第一次海报我希望有人能帮助我的VBA代码。我有一些VBA编码的经验，但我没有知识或专业知识来处理我面临的任务我有一份关于实体及其所有者的报告通过此报告，您可以跟踪每个实体的所有权链以下是报告的一个示例： Entity #, Entity Name, Parent #, Parent Name, Owner % Inside 100 Entity 1 200 Entity2 10

第一次海报

我希望有人能帮助我的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 100%归实体2所有。实体2由实体4和实体5各持有50%的股份。实体3和实体4不为任何附属公司所有。实体5 100%归实体6所有。实体6的25%归实体7所有，25%归实体8所有，50%归实体9所有。实体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

我相信以下内容将满足您的要求。（这可能是将基于多个父母的“所有权百分比”与各自的“所有权百分比”关联起来的唯一真实方法。）

公共实体作为新字典
作为变量的公共MainArray（）
“我假设您在问题中发布的表格代表Excel电子表格的A列到F列。
'更改以下常量，使其适合您的实际布局。
常量集合为整数=1'假定列A
Const colParent As Integer=3'假定为列C
Const colPct作为整数=5'假设列E
常数colInside为整数=6'假定为F列
子计算
Dim g为整数，r为整数，m为整数
将主量程变暗为量程
m=单元格（Rows.Count，“A”）。结束（xlUp）。行
设置主范围=范围（“a2:J”和m）
MainArray（）=MainRange
'将每个实体添加到字典中，并通过将其设置为-1将百分比标记为未计算
对于g=1到uBond（主阵列，1）
如果实体不存在（MainArray（g，colEntity）），则
实体。添加主数组（g，colEntity），-1
如果结束
如果不存在entities.Exists（MainArray（g，colParent）），则
如果MainArray（g，colInside）=“否”，则
'如果实体不在“内部”，则存储该实体为0%所有的事实
实体。添加MainArray（g，colParent），0
其他的
实体。添加MainArray（g，colParent），-1
如果结束
如果结束
下一个
r=0
对于实体中的每个e。键
计算
'将结果写入N列和O列，以便我们可以看到它们
r=r+1
单元（r，14）=e
单元（r，15）=实体（e）
下一个
端接头
子计算PCT（e作为变量）
作为整数的Dim g
双精度pct
Dim Owned100Pct作为布尔值
如果实体（e）<0，则
pct=0
Owned100Pct=True“跟踪实体是否存在于表中而不是作为父项
对于g=1到uBond（主阵列，1）
如果主数组（g，colEntity）=e，则
Owned100Pct=False
如果实体（MainArray（g，colParent））=-1，则
如果我们不知道父母的所有权百分比，就去计算一下
CalculatePct主阵列（g，colParent）
如果结束
pct=pct+CDbl（MainArray（g，colPct））/100*个实体（MainArray（g，colParent））
如果结束
下一个
如果拥有100%，则
“如果我们不知道父母是谁，假设我们100%拥有
“（“外部”实体不会通过此处，因为它们已设置为0%）
实体（e）=1
其他的
'存储实体的百分比
实体（e）=pct
如果结束
如果结束
端接头

我相信以下内容将满足您的要求。（这可能是将基于多个父母的“所有权百分比”与各自的“所有权百分比”关联起来的唯一真实方法。）

公共实体作为新字典
作为变量的公共MainArray（）
“我假设您在问题中发布的表格代表Excel电子表格的A列到F列。
'更改以下常量，使其适合您的实际布局。
常量集合为整数=1'假定列A
Const colParent As Integer=3'假定为列C
Const colPct作为整数=5'假设列E
常数colInside为整数=6'假定为F列
子计算
Dim g为整数，r为整数，m为整数
将主量程变暗为量程
m=单元格（Rows.Count，“A”）。结束（xlUp）。行
设置主范围=范围（“a2:J”和m）
MainArray（）=MainRange
'将每个实体添加到字典中，并通过将其设置为-1将百分比标记为未计算
对于g=1到uBond（主阵列，1）
如果实体不存在（MainArray（g，colEntity）），则
实体。添加主数组（g，colEntity），-1
如果结束
如果不存在entities.Exists（MainArray（g，colParent）），则
如果MainArray（g，colInside）=“否”，则
'如果实体不在“内部”，则存储该实体为0%所有的事实
实体。添加MainArray（g，colParent），0
其他的
实体。添加MainArray（g，colParent），-1
如果结束
如果结束
下一个
r=0
对于实体中的每个e。键
计算
'写结果t
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