VBA あるセルの右上のセルが空白でないとき、あるセルの上から右10列にわたって行を挿入したい

Question

目的はサブフォルダまでまとめてマクロで自動作成するために、エクセルに作成したフォルダ構成一覧表を自動作成用に調整する作業を自動化することです。
まず、フォルダ構成一覧表は以下の形式で作成する予定です。

|第一階層|第二階層|第三階層|第四階層|
|:--|:--:|--:|
|A|1|①|ア|　　　　　
||2|①|ア|
|||②|ア
|B|1|①|ア

ただ、フォルダを自動で作成する際、下のマクロを使用するつもりですが、各階層ごとに行をずらす必要があります。
|第一階層|第二階層|第三階層|第四階層|
|:--|:--:|--:|
|A||||　　　　　
||1|||
|||①||
||||ア|
||2|||
|||①||
||||ア|
|||②|
||||ア
|B|||
||1||
|||①|
||||ア

このずらす内容を言葉で表すと
「第一階層列の文字が入力されているセルの右上に文字が入力されている場合、第一階層から第四
階層まで行挿入、下のセルを探しに行き繰り返す。次に第二階層でも同様の探索を行い、行挿入の範囲だけ第二階層から第四階層までに変更。以降繰り返し」になりますが、これをマクロで作成する方法が分からないので質問しました。

ただ、そもそもフォルダ作成時に表の調整が必要な下のマクロを使うのではなく、ほかにも良い方法があればそちらをご紹介いただけると幸いです。
よろしくお願いいたします。

Sub makefolder()
    Dim i As Long, cmax As Long, x As Long, z As Long, cnt As Long, j As Long, k As Long
    Dim ws1 As Worksheet
    Dim str As String, url As String
    Dim s As String, s1 As String
    Dim n1 As Long
    
    Dim fs As FileSystemObject
    Set fs = New Scripting.FileSystemObject
    
    Set ws1 = Worksheets("A")
    
    cmax = ws1.Range("A65536").End(xlUp).Row
    cnt = ws1.Range("IV4").End(xlToLeft).Column
    '[1] セルB2にURLが記載されているかチェック
    If ws1.Range("B2").Value = "" Then
        MsgBox "セルB2に「作成先のフォルダURL」を入力して下さい"
        ws1.Range("B2").Activate
        Exit Sub
    End If
    url = ws1.Range("B2").Value
    '[2] 同じ行に複数回記入されていないことを確認
        For i = 5 To cmax
        x = 0
        For j = 0 To cnt - 2
            If ws1.Range("B" & i).Offset(0, j).Value <> "" Then
                x = x + 1
            End If
        Next
        If x > 1 Then
            z = z + 1
        End If
    Next
    '[3] 同じ行に複数回記入されていた場合、処理を止める
    If z > 0 Then
        MsgBox "入力情報を見直してください"
        Exit Sub
    End If
    '[4] 階層別にフォルダを作成する
    For j = 0 To cnt - 2
        For i = 5 To cmax
            s = ""
            If ws1.Range("B" & i).Offset(0, j).Value <> "" Then
                s1 = ws1.Range("B" & i).Offset(0, j).Value
                For k = 0 To j
                    If k - j = 0 Then
                        Exit For
                    End If
                    n1 = ws1.Range("B" & i).Offset(0, j - k - 1).End(xlUp).Row
                    s1 = ws1.Range("B" & n1).Offset(0, j - k - 1).Value & "\" & s1
                Next
                s = url & "\" & s1
                fs.CreateFolder s
            End If
        Next
    Next
    Set fs = Nothing
End Sub





コード

Comments

[meg_]

やりたいことは下記のどちらでしょうか？
> 主目的はエクセルにフォルダ構成一覧表を作成し
> フォルダを自動で作成する際

[ttyp03]

> あるセルの上から右10列にわたって行を挿入したい
> 第一階層から第四階層まで行挿入

列の話をしているのに行挿入になるのがわかりません。
手作業で言うと「セルの挿入→下方向にシフト」のことでしょうか？

[ttyp03]

あとmeg_さんもおっしゃってますが、表を作成したいのか、できている表を元にフォルダを作成したいのか、どっちなんでしょうか？

[退会済みユーザー]

>meg
やりたいことは「第一階層列の文字が入力されているセルの右上に文字が入力されている場合、第一階層から第四階層まで行挿入、下のセルを探しに行き繰り返す。次に第二階層でも同様の探索を行い、行挿入の範囲だけ第二階層から第四階層までに変更。以降繰り返し」です。わかりにくくて申し訳ないです。

>ttyp03
>手作業で言うと「セルの挿入→下方向にシフト」のことでしょうか？
おっしゃる通りです

[退会済みユーザー]

フォルダ構成（ディレクトリ）を取得すると次のサイトのように表示されます。
https://qiita.com/ditflame/items/d6c96ac60a0665cb1bcd
最終的にやりたいことは逆で、表示されている状態からフォルダを作成するのですが、質問内の表を「表示されている状態」に行挿入等で調節する必要があり、その調節方法を今回質問させていただいてます。

[Usirow]

すみません。
質問内容やここでのやり取りを見るに、質問で提示されている表は最終的に求めているものではないという風に読めるのですが、そのような理解でいいのでしょうか。

[退会済みユーザー]

>Usirow
おっしゃる通りです。ややこしくて申し訳ありません。

[hatena19]

マクロ実行前の表と、実行後の表を提示してもらうと、皆さんに伝わりやすいかも。

[退会済みユーザー]

＞hatena19
ちょうど書き直していました。おっしゃる通りです。

[meg_]

階層は｢第四階層｣で打ち止めですか？

[退会済みユーザー]

>meg_
5階層で打ち止めにします。最初は「エクセルに記入があるだけ」を考えておりましたが、5階層以下は使用しないようにするので5階層まででお願いいたします。

Answer 1

データを配列に格納してから、出力する方法にしてみました。

Public Sub test()
    Dim rngData As Range
    Set rngData = Range("A1").CurrentRegion
    Set rngData = rngData.Offset(1).Resize(rngData.Rows.Count - 1) 'データ範囲を取得

    Dim aryData
    aryData = rngData.Value 'データ範囲を配列に格納
    rngData.ClearContents

    Dim r As Long, c As Long, outR As Long
    
    outR = 1
    For r = 1 To UBound(aryData)
        For c = 1 To UBound(aryData, 2)
            If aryData(r, c) <> "" Then
                outR = outR + 1
                Cells(outR, c).Value = aryData(r, c)
            End If
        Next
    Next

End Sub

1行目は項目名で2行目からデータが入力されているとします。

Comments

[ttyp03]

やっぱり配列化したほうが処理が楽ですね。

[退会済みユーザー]

こちらでも同じようにやりたいことができました！ありがとうございます！

Answer 2

なんとなく「各行に1つのフォルダが存在するように編集する」という風に読み取れましたが、あっていますでしょうか？
で、書いてみたのが以下。
ディレクトリ作成と同時に行う必要はないと思うので、作成が終わってから実行するように組み込んでみてください。

Sub test()
    Dim r As Long
    Dim c As Long
    Dim c2 As Long
    Dim lc As Long
    r = 2
    Do While Application.WorksheetFunction.CountA(Rows(r)) > 0
        lc = Cells(r, Columns.Count).End(xlToLeft).Column
        For c = 1 To lc - 1
            If Cells(r, c).Value <> "" Then
                Rows(r + 1).Insert
                For c2 = c + 1 To lc
                    Cells(r + 1, c2).Value = Cells(r, c2).Value
                    Cells(r, c2).ClearContents
                Next
                r = r + 1
            End If
        Next
        r = r + 1
    Loop
End Sub

Comments

[ttyp03]

あ、追加の質問編集があったようですね。
イメージ通りでした。

[退会済みユーザー]

まさしくやりたいことができました！ありがとうございました！