使用VBA快速梳理多层级族谱（组织架构）

news2024/11/17 1:40:45

实例需求：族谱（或者公司组织架构等）都是典型的带有层级关系数据，例如下图中左侧表格所示。

A列为层级（准确的讲是B列成员的层级），从一开始递增
B列和C列为成员直接的父（/母）子（/女）关系
D列为辅助标记

现需要整理为右侧表格的形式，按照每个家族链依次排列，如标记颜色部分所示。

在这里插入图片描述

由于每个层级的成员梳理，层级深度不确定，因此需要使用递归过程实现。

实例代码如下。

Dim arrRes(), iR As Long
Sub Demo()
    Dim i As Long, j As Long, objDic As Object
    Dim arrData, rngData As Range, aRow(1 To 4)
    Dim sParent As String, sChild As String, sFirst As String
    Set rngData = ActiveSheet.Range("A1").CurrentRegion
    arrData = rngData.Value
    ReDim arrRes(1 To UBound(arrData), 1 To 4)
    iR = 1
    For j = 1 To 4
        arrRes(iR, j) = arrData(1, j)
    Next
    Set objDic = CreateObject("scripting.dictionary")
    For i = LBound(arrData) To UBound(arrData)
        If arrData(i, 1) = 1 Then 
            If Len(sFirst) > 0 Then
                Call GetChild(objDic, "", sFirst)
                objDic.RemoveAll
            End If
            sFirst = arrData(i, 3)
        End If
        sParent = arrData(i, 2): sChild = arrData(i, 3)
        If Not objDic.exists(sParent) Then
            Set objDic(sParent) = CreateObject("scripting.dictionary")
        End If
        For j = 1 To 4
            aRow(j) = arrData(i, j)
        Next
        objDic(sParent)(sChild) = aRow()
    Next i
    Call GetChild(objDic, "", sFirst)
    With ActiveSheet.Range("F1").Resize(iR, 4)
        .EntireColumn.Clear
        .Value = arrRes
    End With
End Sub
Sub GetChild(oDic As Object, sParent As String, sChild As String)
    Dim vKey, aRow, j As Long
    aRow = oDic(sParent)(sChild)
    iR = iR + 1
    For j = 1 To 4
        arrRes(iR, j) = aRow(j)
    Next
    If oDic.exists(sChild) Then
        For Each vKey In oDic(sChild).keys
            Call GetChild(oDic, sChild, vKey)
        Next
    End If
End Sub

【代码解析】
第1行代码声明模块基本变量，用于保存结果数据。
第2~36行代码为主过程。
第6行代码获取A1开始的当前数据区域。
第7行代码将数据加载到数组中。
第8行代码为结果数组分配存储空间。
第10~12行代码将表头复制到结果数组中。
第13行代码创建字典对象。
第14~30行代码循环处理每行数据。
第15行代码判断当前数据是否为第一级。
如果是的话，第16~20行代码进行相应处理。
第16行代码判断sFirst变量是否为空，如果不为空，说明从该行开始一个新的族系。
第17行代码调用递归过程GetChild()，将objDic对象中保存的族谱整理到结果数组中。
第18行代码清空字典对象。
第20行代码将当前行的C列成员保存到sFirst变量中。
第22行代码分别读取B列和C列数据。
第23行代码判断父成员是否已经存在于字典对象中，如果不存在，第24行代码创建一个嵌套的字典对象。
第26~28行代码将该行4个数据保存到临时数组变量aRow中。
第29行代码将行数据保存到嵌套字典对象中，父成员为外层字典的键，子成员为内层字典的键。
第31行代码作用与第17行相同，用于处理最后一个家族。
第32行代码为结果输出区域Range对象。
第33行代码清空输出区域。
第34行代码将结果写入工作表。
第37~49行代码为递归过程用于查找下一级子成员。
第39行代码读取嵌套字典对象中保存的行数据。
第40行行指针标记递增，由于iR是模块级别变量，因此每次在GetChild中调用此变量时，仍保留原值，不会被初始化。
第41~43行代码将行数据写入结果数组中。
第44行代码判断字典中是否存在子成员的键，如果存在的话，说明该成员具备下一级子成员（即孙成员）。
第46行代码再次调用递归过程，注意此处的参数值，sChild作为第二个参数，即作为下一次调用的父成员。