Excel VBで単一行のセルから階層/ストローモデルを構築する

Question

フラットな階層にあるセルの行を取り出す方法を理解する助けが必要です（セルA：1 =レベル1、セルA：2 =レベル2など）、各レベルがストローモデルのように別々の行になるようにビルドします。私は必要なもの

：

To-Be What I need

そして、これは私が例えば持っているものです。

As-Is Flat hierarchy

私はただ、私として必要とされるもののまわりで私の頭をラップすることはできませんセルを下に移動して階層のように見えるコードを持っていますが、論理を真っ直ぐ微調整して見た目をきれいにすることはできません。私は、異なる階層を持つ多くの異なる親を持ち、それらを通過して、手動で値をコピーして貼り付ける必要はありません。

私は他のstackoverflowの質問から一緒に引っ張ってきたコードを使用していますが、それは正しい軌道に乗っていますが、私がTo-Beイメージのように見えるようにするために何が欠けているかを知る助けが必要です上記。このコードでは、階層内に8つのレベルがあると想定していますが、各階層の最も低いレベル（最も細かいレベル）を見つけ出し、各レベルのif文を作成する必要はありません。子サブレベル。 ：思考？

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 

End Subの

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