我試圖創建一個Excel層次結構（非常類似于這個問題）
我希望將其作為資料透視表中的可擴展層次結構或通過 VBA（以更簡單的方式），如下所示：
雖然上圖顯示了 Tier，但我想要的輸出將使用 Level 值。這就是上面提到的結構意味著它不像遵循鏈接問題中的步驟那么容易。
這是我想要實作的一個例子。
任何幫助或指導將不勝感激。
謝謝，斯蒂芬。
uj5u.com熱心網友回復：
該腳本只需要這些列：
Option Explicit
Public Sub Example()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Source")
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
' read data into array
Dim PartNumber() As Variant
PartNumber = ws.Range("D2", "D" & LastRow).Value
Dim PartDescription() As Variant
PartDescription = ws.Range("E2", "E" & LastRow).Value
Dim PartLevel() As Variant
PartLevel = ws.Range("F2", "F" & LastRow).Value
Dim PartParent() As Variant
PartParent = ws.Range("G2", "G" & LastRow).Value
' creat a tree
Dim RootTree As Object
Set RootTree = CreateObject("Scripting.Dictionary")
' fill tree with data
Dim iRow As Long
For iRow = LBound(PartNumber, 1) To UBound(PartNumber, 1)
If PartLevel(iRow, 1) = 0 Then
' create root
' ------------
RootTree.Add PartNumber(iRow, 1), CreateObject("Scripting.Dictionary")
Else
' create all children
' --------------------
Dim BacktraceLevel As Long
BacktraceLevel = PartLevel(iRow, 1)
ReDim Backtrace(1 To BacktraceLevel)
Backtrace(BacktraceLevel) = PartParent(iRow, 1)
BacktraceLevel = BacktraceLevel - 1
' backtrace from current child to root
Do While BacktraceLevel > 0
DoEvents
Dim FoundAt As Double
FoundAt = Application.WorksheetFunction.Match(Backtrace(BacktraceLevel 1), PartNumber, 0)
If PartLevel(FoundAt, 1) <> 0 Then
Backtrace(BacktraceLevel) = PartParent(FoundAt, 1)
End If
BacktraceLevel = BacktraceLevel - 1
Loop
' climb tree until child can be added
Dim Parent As Object
Set Parent = RootTree
Dim b As Long
For b = 1 To UBound(Backtrace)
Set Parent = Parent(Backtrace(b))
Next b
' add current child
Parent.Add PartNumber(iRow, 1), CreateObject("Scripting.Dictionary")
End If
Next iRow
' output tree
OutputTree RootTree, Worksheets("output").Range("A1"), PartNumber, PartDescription
End Sub
Private Sub OutputTree(ByVal Tree As Object, ByVal StartOutput As Range, ByVal PartNumber As Variant, ByVal PartDescription As Variant, Optional ByVal Level As Long = 0)
Static iRow As Long
Dim Key As Variant
For Each Key In Tree.Keys
StartOutput.Offset(RowOffset:=iRow, ColumnOffset:=Level).Value = PartDescription(Application.WorksheetFunction.Match(Key, PartNumber, 0), 1)
iRow = iRow 1
If VarType(Tree(Key)) = 9 Then
OutputTree Tree(Key), StartOutput, PartNumber, PartDescription, Level 1
End If
Next
End Sub
它會輸出
轉載請註明出處，本文鏈接：https://www.uj5u.com/yidong/334644.html