Excel VBA 从关系数据中获取祖先值

Question

我似乎无法弄清楚这在 excel VBA 中是如何工作的

我在 excel 中有这样的关系数据：

分层/树视图，数据如下：

数据的最终结果应如下所示（使用 excel VBA 脚本后）其中

• A 列和 B 列是关系数据
• E 列是查找的输入值
• F 列是结果祖先值

到目前为止，我的脚本如下所示：

Public Sub DictionaryExamples()

    Dim sht As Worksheet: Set sht = ActiveSheet

    Dim exampleValues As Variant
    Dim i As Long
    Dim aKey As String
    Dim aValue As String
    Dim exampleDict As Object

    'Load values into a variant array
    exampleValues = Range("A1:B15").Value

    'Instantiate a dictionary
    Set exampleDict = CreateObject("scripting.dictionary")

    'Read all keys and values, and add them to the dictionary

    For i = 1 To UBound(exampleValues)
        aKey = CStr(exampleValues(i, 1))
        aValue = CStr(exampleValues(i, 2))
        exampleDict.Add aKey, aValue
    Next i

    'After Dictionary setup, use input values E to output Ancestor F
    Dim curCell As Range
    Dim LastRow As Long
    Dim temp As Variant

    LastRow = sht.Cells(Rows.Count, "E").End(xlUp).row

    'Loop through all values in parent to find ancestor
    For Each curCell In sht.Range("E1:E" & LastRow).Cells
        temp = curCell

        'Search Dictionary until no matches are found, that is ancestor
        Do
            If exampleDict.Exists(temp) Then
                temp = exampleDict(temp)
            Else
                'Print ancestor
                curCell(, 2).Value = temp
                Exit Do
            End If
        Loop

    Next



End Sub

目前的结果：（没有得到正确的输出值）

基本上我使用字典（A=键，B=值）来查找（E=输入）然后输出（F=结果）

循环多次，直到找到一个没有对的键，并使用最新的工作键值作为祖先

数据中的“根”字是不必要的，我只是把它放在那里是为了澄清，它可能是一个空值我只是想澄清哪些输入级别已经是顶级祖先值

Answer 1

在继续循环之前，您需要测试您的子节点的父节点是根元素还是叶（子节点）本身。否则，您将始终写入父节点的值，即“Root”，而不是父节点的名称（键）。

显式选项

Public Sub DictionaryExamples()

    Dim sht As Worksheet: Set sht = ActiveSheet
    Dim exampleValues As Variant
    Dim i As Long
    Dim aKey As String, aValue As String
    Dim exampleDict As Object
    Dim curCell As Range

    'Load values into a variant array
    exampleValues = Range("A2:B15").Value

    'Instantiate a dictionary
    Set exampleDict = CreateObject("scripting.dictionary")

    'Read all keys and values, and add them to the dictionary

    For i = 1 To UBound(exampleValues)
        aKey = CStr(exampleValues(i, 1))
        aValue = CStr(exampleValues(i, 2))
        exampleDict.Add aKey, aValue
    Next i

    'After Dictionary setup, use input values E to output Ancestor F


    With sht
        'Loop through all values in parent to find ancestor
        For Each curCell In .Range("E2", .Cells(Rows.Count, "E").End(xlUp))
            aKey = curCell
            'If the
            If Not exampleDict.Exists(exampleDict(aKey)) Then
                'If the node is a parent node print it's value
                'To avoid confusion I'd have used: curCell(, 2).Value = "Parent Node"
                curCell(, 2).Value = exampleDict(aKey)
            Else
                'Search Dictionary until no matches are found, that is ancestor
                Do
                    If exampleDict.Exists(aKey) Then
                        'Here we test if this child node's parent is a root node
                        If Not exampleDict.Exists(exampleDict(aKey)) Then
                            'The child node's parent is a root node
                            curCell(, 2).Value = aKey
                            Exit Do
                        Else
                            'The child node's parent is also a leaf so continue
                            aKey = exampleDict(aKey)
                        End If
                    End If
                Loop
            End If
        Next
    End With

End Sub

Answer 2

另一个解决方案（不是我原来的解决方案，在其他地方得到了帮助）

Option Explicit

Private Const LOOP_LIMIT As Integer = 100

Public Sub LineageDemo()

    Dim dict As Object
    Dim inputValues As Variant
    Dim outputValues As Variant
    Dim i As Long

    'Read relations into dictionary
    Set dict = BuildDictionaryOfRelations(Range("A2:A140"), Range("B2:B140"))

    'Read input values into variant array
    inputValues = Range("E2:E1465").Value

    'Write output
    ReDim outputValues(1 To UBound(inputValues), 1 To 1)
    For i = 1 To UBound(inputValues)
        outputValues(i, 1) = TraceAncestor(CStr(inputValues(i, 1)), dict, "Root")
    Next i

    Range("F2:F1465").Value = outputValues

End Sub

Private Function BuildDictionaryOfRelations(childRange As Range, parentRange As Range) As Object

    Dim childValues As Variant
    Dim parentValues As Variant
    Dim i As Long
    Dim aChild As String
    Dim aParent As String
    Dim dict As Object

    If childRange.Columns.Count <> 1 Or parentRange.Columns.Count <> 1 _
        Or childRange.Rows.Count <> parentRange.Rows.Count Then _
        Err.Raise vbObjectError + 1, Description:="Bad/inconsistent category ranges"

    'Load values into variant arrays
    childValues = childRange.Value
    parentValues = parentRange.Value

    'Instantiate a dictionary
    Set dict = CreateObject("scripting.dictionary")

    'Populate the dictionary

    For i = 1 To UBound(childValues)
        aChild = CStr(childValues(i, 1))
        aParent = CStr(parentValues(i, 1))
        If aChild = "pizza-oven" Then Stop
        dict.Add aChild, aParent
    Next i

    Set BuildDictionaryOfRelations = dict

End Function

Private Function TraceAncestor(aChild As String, relationDict As Object, rootString As String) As String

    Dim aParent As String
    Dim i As Integer

    If Not (relationDict.exists(aChild)) Then
        TraceAncestor = "ERROR: " & aChild & " does not appear in the CategoryName column"
        Exit Function
    End If

    'If aChild is a root, return root
    If relationDict.Item(aChild) = rootString Then
        TraceAncestor = rootString
        Exit Function
    End If

    'Trace from child to parent to parent to parent... to find ultimate ancestor
    For i = 1 To LOOP_LIMIT
        If Not (relationDict.exists(aChild)) Then
            TraceAncestor = "ERROR: " & aChild & " does not appear in the CategoryName column"
            Exit Function
        End If
        aParent = relationDict.Item(aChild)
        If aParent = rootString Then Exit For
        aChild = aParent
    Next i

    If i > LOOP_LIMIT Then
        TraceAncestor = "ERROR: Ancestor could not be found for " & aChild & " in " & LOOP_LIMIT & " iterations"
        Exit Function
    End If

    TraceAncestor = aChild

End Function

Answer 3

我只有大约 1000 到 2000 个左右的单元格，所以我最终在这里使用了 Jerry 的级联树公式

https://sites.google.com/a/madrocketscientist.com/jerrybeaucaires-excelassistant/text-functions/cascading-tree

Option Explicit

Sub TreeStructure()
'JBeaucaire  3/6/2010, 10/25/2011
'Create a flow tree from a two-column accountability table
Dim LR As Long, NR As Long, i As Long, Rws As Long
Dim TopRng As Range, TopR As Range, cell As Range
Dim wsTree As Worksheet, wsData As Worksheet
Application.ScreenUpdating = False

'Find top level value(s)
Set wsData = Sheets("Input")
  'create a unique list of column A values in column M
    wsData.Range("A:A").AdvancedFilter Action:=xlFilterCopy, _
         CopyToRange:=wsData.Range("M1"), Unique:=True

  'Find the ONE value in column M that reports to no one, the person at the top
    wsData.Range("N2", wsData.Range("M" & Rows.Count).End(xlUp) _
        .Offset(0, 1)).FormulaR1C1 = "=IF(COUNTIF(C2,RC13)=0,1,"""")"
    Set TopRng = wsData.Columns("N:N").SpecialCells(xlCellTypeFormulas, 1).Offset(0, -1)
  'last row of persons listed in data table
    LR = wsData.Range("A" & wsData.Rows.Count).End(xlUp).Row

'Setup table
    Set wsTree = Sheets("LEVEL STRUCTURE")
    With wsTree
        .Cells.Clear    'clear prior output
        NR = 3          'next row to start entering names

'Parse each run from the top level
    For Each TopR In TopRng         'loop through each unique column A name
        .Range("B" & NR) = TopR
        Set cell = .Cells(NR, .Columns.Count).End(xlToLeft)

        Do Until cell.Column = 1
          'filter data to show current leader only
            wsData.Range("A:A").AutoFilter Field:=1, Criteria1:=cell
        'see how many rows this person has in the table
            LR = wsData.Range("A" & Rows.Count).End(xlUp).Row
            If LR > 1 Then
              'count how many people report to this person
                Rws = Application.WorksheetFunction.Subtotal(103, wsData.Range("B:B")) - 1
              'insert that many blank rows below their name and insert the names
                cell.Offset(1, 1).Resize(Rws).EntireRow.Insert xlShiftDown
                wsData.Range("B2:B" & LR).Copy cell.Offset(1, 1)
              'add a left border if this is the start of a new "group"
                If .Cells(.Rows.Count, cell.Column + 1).End(xlUp).Address _
                    <> cell.Offset(1, 1).Address Then _
                       .Range(cell.Offset(1, 1), cell.Offset(1, 1).End(xlDown)) _
                          .Borders(xlEdgeLeft).Weight = xlThick
            End If

            NR = NR + 1     'increment to the next row to enter the next top leader name
            Set cell = .Cells(NR, .Columns.Count).End(xlToLeft)
        Loop
    Next TopR

  'find the last used column
    i = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), _
        SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
  'format the used data range
    With Union(.Range(.[B1], .Cells(1, i)), .Range("B:BB").SpecialCells(xlCellTypeConstants, 23))
        .Interior.ColorIndex = 5
        .Font.ColorIndex = 2
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
    .Range("B1").Interior.ColorIndex = 53
    .Range("B1").Value = "LEVEL 1"
    .Range("B1").AutoFill Destination:=.Range("B1", .Cells(1, i)), Type:=xlFillDefault
End With

wsData.AutoFilterMode = False
wsData.Range("M:N").ClearContents
wsTree.Activate
Application.ScreenUpdating = True
End Sub

这完成了我需要做的 95% 的工作，其余的我只使用了 excel 公式（之后不需要 VBA）

从头获取祖先数据的步骤：

我做了以下程序：

0：在关系数据设置中有数据

1：清除所有重复数据重复的条件格式

2：运行 Jerry 的 Excel VBA 宏。结果如下

Col A | ColB  | ColC  | ColD  | ColE  | ColF  |
      | Lvl1  | Lvl2  | Lvl3  | Lvl4  | Lvl5  |

      | AAA   |       |       |       |       |
      |       | BBB   |       |       |       |
      |       | EEE   |       |       |       |
      |       | FFF   |       |       |       |       
      | CCC   |       |       |       |       |
      |       | GGG   |       |       |       |       
      |       |       | III   |       |       |
      |       |       |       | JJJ   |       |
      |       |       |       |       | KKK   |
      | DDD   |       |       |       |       |
      |       | HHH   |       |       |       |

3：通过excel复制+粘贴的方式填充顶级excel（我只有3个父顶级类别，所以花了2分钟）

Col A | ColB  | ColC  | ColD  | ColE  | ColF  |
      | Lvl1  | Lvl2  | Lvl3  | Lvl4  | Lvl5  |

      | AAA   |       |       |       |       |
      | AAA   | BBB   |       |       |       |
      | AAA   | EEE   |       |       |       |
      | AAA   | FFF   |       |       |       |       
      | CCC   |       |       |       |       |
      | CCC   | GGG   |       |       |       |       
      | CCC   |       | III   |       |       |
      | CCC   |       |       | JJJ   |       |
      | CCC   |       |       |       | KKK   |
      | DDD   |       |       |       |       |
      | DDD   | HHH   |       |       |       |

4：然后通过此公式在 A 列中使用辅助列

=IF(B19<>"", B19, IF(C19<>"",C19, IF(D19<>"",D19, IF(F19<>"",F19))))

其中 C、D、E、F 是源自父级的子类别级别（B 列）。这会搜索 C 列中的值作为输入，如果不存在，则搜索 D 列、E 列、F 列并复制它首先找到的任何内容。

Col A | ColB  | ColC  | ColD  | ColE  | ColF  |
      | Lvl1  | Lvl2  | Lvl3  | Lvl4  | Lvl5  |

      | AAA   |       |       |       |       |
  BBB | AAA   | BBB   |       |       |       |
  EEE | AAA   | EEE   |       |       |       |
  FFF | AAA   | FFF   |       |       |       |       
      | CCC   |       |       |       |       |
  GGG | CCC   | GGG   |       |       |       |       
  III | CCC   |       | III   |       |       |
  JJJ | CCC   |       |       | JJJ   |       |
  KKK | CCC   |       |       |       | KKK   |
      | DDD   |       |       |       |       |
  HHH | DDD   | HHH   |       |       |       |

5：现在使用我的原始输入值作为查找所有数据（在列 A 和 B 上）标准化，然后使用索引/匹配函数

6：事后手动清理所有数据

对于较大的数据集，可以轻松地对第 3 步进行宏化，只需遍历该列并粘贴，直到找到下一个值。