Excel VB 从单行中的单元格构建层次结构/稻草模型

Question

我需要你的帮助，帮助我弄清楚如何在平面层次结构中获取一行单元格（Cell A:1 = level 1，Cell A:2 = level 2 等。 ..) 并构建它，使每个级别都像吸管模型一样位于单独的行中。

我需要的：

然后这就是我的例子：

我只是无法理解需要什么，因为我已经有了将单元格向下移动并看起来像层次结构的代码，但我似乎无法对逻辑进行恰到好处的调整以给我一个干净的看起来很光滑 sheet。我将有很多不同的 parents 和不同的层次结构，并且不想继续浏览它们并手动复制和粘贴值。

这是我一直在使用的代码，是我从其他 Whosebug 问题中提取出来的，它让我在某种程度上走上了正确的轨道，但需要帮助才能看到我遗漏了什么，让它看起来像 To-Be 上图。该代码假定我在层次结构中有 8 个级别，但我想以编程方式找到每个层次结构的最低级别（最细粒度的级别）并跳过必须为每个级别创建和 if 语句的想法，因为我可以有一些层次结构 30 child 个子级别。 : 想法?

Sub Button1_Click()
 Dim rng As Range
 Dim row As Range
 Dim cell As Range
 Dim lcol As Long

For x = 8 To 1 Step -1
    lcol = Cells(x, Columns.Count).End(xlToLeft).Column
    If IsEmpty(Cells(x, 8)) = False Then
        Cells(x, 8).Select
        For Z = 1 To 8
            Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
            Rows(lcol).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        Next
    End If

    If IsEmpty(Cells(x, 7)) = False Then
        Cells(x, 7).Select
        For Z = 1 To 7
            Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        Next
    End If
    If IsEmpty(Cells(x, 6)) = False Then
        Cells(x, 6).Select
        For Z = 1 To 6
            Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        Next
    End If
    If IsEmpty(Cells(x, 5)) = False Then
        Cells(x, 5).Select
        For Z = 1 To 5
            Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        Next
    End If
    If IsEmpty(Cells(x, 4)) = False Then
        Cells(x, 4).Select
        For Z = 1 To 4
            Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        Next
    End If
    If IsEmpty(Cells(x, 3)) = False Then
        Cells(x, 3).Select
        For Z = 1 To 3
            Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        Next
    End If
    If IsEmpty(Cells(x, 2)) = False Then
        Cells(x, 2).Select
        For Z = 1 To 2
            Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        Next
    End If
    If IsEmpty(Cells(x, 1)) = False Then
        Cells(x, 1).Select
        For Z = 1 To 1
            Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        Next
   End If
Next

结束子

Answer 1

我会大量使用数组，如下所示：

Option Explicit

Sub main()
    Dim myArr As Variant, myArr2() As String
    Dim irow As Long, iCol As Long, irow2 As Long

    With Worksheets("Hierarchy").Range("A1").CurrentRegion
        myArr = .Cells.value
        ReDim myArr2(1 To WorksheetFunction.CountA(.Cells) + .Rows.Count - 1, 1 To .Columns.Count)
    End With

    For irow = LBound(myArr, 1) To UBound(myArr, 1)
        For iCol = LBound(myArr, 2) To UBound(myArr, 2)
            If Not IsEmpty(myArr(irow, iCol)) Then
                irow2 = irow2 + 1
                myArr2(irow2, iCol) = myArr(irow, iCol)
            End If
        Next iCol
        irow2 = irow2 + 1
    Next irow

    Worksheets("Hierarchy").Range("A1").Range("A1").Resize(UBound(myArr2, 1), UBound(myArr2, 2)).value = myArr2
End Sub

Answer 2

下面的代码将完成这项工作

Sub Button1_Click()

i = 1
row_loc = 2

Do While Cells(i, 1).Value <> ""
    childs = Cells(i, Columns.Count).End(xlToLeft).Column - 1
    For j = 1 To childs
        Rows(row_loc & ":" & row_loc).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        Cells(row_loc, j + 1).Value = Cells(i, j + 1).Value
        Cells(i, j + 1).Value = ""
        row_loc = row_loc + 1
    Next j
    i = row_loc
    row_loc = row_loc + 1
Loop

End Sub

Excel VB 从单行中的单元格构建层次结构/稻草模型

Excel VB to build a Hierarchy / Straw model from cells that are in a single row

vb.net

excel

vba

hierarchy