Excel VBA从关系数据中获取祖先值
我似乎无法弄清楚如何在Excel VBA中工作
我在excel中有这样的关系数据：
分层/ treeview，数据看起来像这样：
数据的最终结果应该是这样的（使用excel VBA脚本之后）在哪里
- 列A和B是关系数据
- 列E是用于查找的input值
- 列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 =input），然后输出（F =结果）
我循环多次直到find一个没有配对的密钥，并使用最新的工作密钥值作为祖先
数据中的“根”字是无意义的我只是把它放在那里澄清，它可能是一个空值，我只是想澄清哪些input级已经是顶级祖先值
在继续循环之前，您需要testing您的子节点的父节点是否是根元素，或者是否是叶节点（子节点）。 否则，您将始终写入父节点的值，即“根”，永远不会是父节点的名称（键）。
选项显式
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
另一个解决scheme（不是我原来的解决scheme，在别处得到帮助
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
我只有大约1000到2000个单元，所以我最终在这里使用了Jerry的Cascading树的公式
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：运行杰里的Excel VBAmacros。 下面的结果
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列）。 这将searchC列中的值作为input，如果它不存在，那么列D，然后是E，然后是F，然后复制第一个find的值。
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上），使用我原始的input值作为查找
6：手动清理任何数据
第3步可以很容易地macros观更大的数据集，只是遍历该列和粘贴，直到find下一个值。