excel - 如何创建 Excel 层次结构
问题描述
我正在尝试创建一个 Excel 层次结构(与这个问题非常相似) 创建一个 Excel 层次结构
但我的 Excel 文件的结构完全不同。请通过比较查看我的文件的布局:
我希望将其作为数据透视表中的可扩展层次结构或通过 VBA(更简单的方法),如下所示:
虽然上图显示了 Tier,但我想要的输出将使用 Level 值。这就是上面提到的结构意味着它不像按照链接问题中的步骤那么容易。
这是我想要实现的一个例子。
任何帮助或指导将不胜感激。
谢谢,斯特凡。
解决方案
该脚本将只需要这些列:
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
它会输出
推荐阅读
- colors - 从整数到十六进制的颜色转换?
- rest - 带有 .Include 的 Entity Framework Core API 返回表
- visual-studio - How to setup TFS 2013 to build either with Visual Studio 2013 or Visual Studio 2017
- vba - VBA Excel-基于具有匹配数据的两列复制行
- r - 将列表添加到数据框中的每一行
- python - Pandas.Dataframe 在 1 列上选择最大值,在其他列上选择另一个标准。
- apache - 删除包含参数的部分 url
- java - 同时为矢量可绘制对象的许多部分设置动画
- r - How do I deal with an Ifelse condition that is not giving me an error but is also not giving me any change in my output?
- ruby-on-rails - What is the correct way to use moment.js locale in rails?