（作成例）エクセルの表を元に、フォルダを作成する

下図のような表を作成してから次のコードを実行すると、

表のとおりにフォルダの階層を作成する。


＜サンプル＞
Const goA As String = "A4" 'ディレクトリの最上層が書かれたセル位置
Const InGyo As Long = 4 '処理を始める行（二回目以降の処理は五行目から行う）

Sub フォルダ作成()
    Dim R As Long, c As Long
    Dim FilePath As String
   
    Dim myLink() As String '出力したことのあるｱﾄﾞﾚｽを格納する
    ReDim Preserve myLink(0)
    Dim myFlag As Boolean 'アドレスを取得しないかどうか
    Dim co As Long
   
    Dim i As Long '処理を行っている階層の位置
    Dim n As Long '処理を行っているフォルダ
    Dim x As Long
   
    '二回目（5行目）以降で使用
    '～子ディレクトリがない→ループから抜ける
    '1回目のfalse　：　親ディレクトリの空白取得中
    'true　　　　　：　空白ではない
    '2回目のfalse　：　再度空白になった→ループから抜ける
    Dim chF As Boolean
   
    R = Range(goA).CurrentRegion.Rows.Count 'ディレクトリの数
    c = Range(goA).CurrentRegion.Columns.Count '階層の深さ
   
    '～～～4行目のディレクトリを構築する
    For i = 1 To c
        '-1-1:パスを取得する
        If FilePath = "" Then
            '一番上の階層（読み込む位置は実質range("A4")
            FilePath = Cells(InGyo, i).Value
        ElseIf Cells(InGyo, i).Value <> "" Then
            FilePath = FilePath & "\" & Cells(InGyo, i).Value
        End If
       
        '-1-2：パスを取得したことのある履歴に保管する
        ReDim Preserve myLink((UBound(myLink) + 1))
        myLink(UBound(myLink)) = FilePath
       
        '-2:空白の場合はフォルダが存在しない
        If Dir(FilePath, vbDirectory) = "" Then
            MkDir FilePath  'フォルダを作成する
        End If
    Next i
   
   
    '～～～5行目以降の処理を行う
    For n = InGyo + 1 To 3 + R
        'フラグを初期値にする
        chF = False
       
        '一旦、FilePathを空白にする
        FilePath = ""
       
        '浅い階層から深い階層へアドレスを読み進める
        For i = 1 To c
            '-0：変数ｘ = FilePathへ代入するｱﾄﾞﾚｽ（列数）
            x = n  '
           
            If Cells(n, i).Value = "" Then
                '空白の場合・・・
                '1：chFがtrue→次の行に移動
                If chF = True Then
                    Exit For
                End If
               
                '2:chFがfalse→上の列を読み込む(最大InGyo-1行目まで）
                Do While Cells(x, i).Value = ""
                    If x = InGyo - 1 Then
                    '読み込み始めの行InGyoよりも上の行になったら処理を中止する
                        Exit Do
                    Else
                        x = x - 1
                    End If
                Loop
            ElseIf Cells(n, i).Value <> "" Then
                '空白でない場合はその値をFilePathへ
                chF = True
            End If
           
           
            '-1:パスを取得する
            If FilePath = "" Then
                '一番上の階層
                FilePath = Cells(x, i).Value
            ElseIf Cells(x, i).Value <> "" Then
                FilePath = FilePath & "\" & Cells(x, i).Value
            End If
           
            '-2:既に取得したことのあるアドレスか確認する
            '既に取得したことがある（myFlag = True）→処理しない
            myFlag = False
            For co = 1 To UBound(myLink)
                If myLink(co) = FilePath Then
                'FilePathは出力したことのアドレスである
                '→今回このｱﾄﾞﾚｽのデータは取得しない
                '∴　ループを抜ける
                    myFlag = True
                    Exit For
                End If
            Next co
           
            'myFlag = True→処理しない
            If myFlag <> True Then
                '-3:FilePathが存在するかどうか調べる
                If Dir(FilePath, vbDirectory) = "" Then
                    '存在しない場合
                    MkDir FilePath  'フォルダを作成する
                End If
            End If
        Next i
    Next n
   
   
    MsgBox "処理が完了しました"
End Sub