VBAでフォルダツリーを一括作成する

階層構造が多岐に渡るフォルダツリーの作成って面倒ですよね。
仕事でそんな必要が生じたので作ってみました。

コード

MakeFolderTree.bas

Option Explicit

Declare PtrSafe Function SHCreateDirectoryEx Lib "shell32" Alias "SHCreateDirectoryExA" ( _
                                                                  ByVal hwnd As Long, _
                                                                  ByVal pszPath As String, _
                                                                  ByVal psa As Long) As Long

Public Const ADR_ROOT       As String = "B2"        ' ツリーのルートフォルダ格納セル(controlシート)
Public Const ADR_FOL_ROOT   As String = "A3"        ' ツリーのルートフォルダ格納セル(treeシート)

Public Const SHT_CTRL       As String = "control"
Public Const SHT_TREE       As String = "tree"

Sub MakeFolderTree()
'*****************************************************
' treeシートに設定したツリー構造でフォルダを作成する
'*****************************************************
    Dim rPath, fPath As String
    Dim csh, tsh As Object
    Dim enRow, enCol, enColMax As Long
    Dim stAdd, enAdd, lastAdd As String
    Dim stRow, lpRow, difRow, lpCol As Long
    Dim pArr(), lastArr() As Variant
    Dim xlfunc As Object
    Dim varFol As String
    Dim sep As String

    Set csh = Sheets(SHT_CTRL)
    Set tsh = Sheets(SHT_TREE)
    Set xlfunc = Application.WorksheetFunction
    sep = Application.PathSeparator         ' Pathの区切り記号("\")

    rPath = csh.Range(ADR_ROOT).Value       ' フォルダツリーのルートフォルダ
    tsh.Range(ADR_FOL_ROOT).Value = rPath   ' treeシートにルートフォルダを入力
    stAdd = ADR_FOL_ROOT                    ' フォルダツリーの先頭セル
    stRow = tsh.Range(stAdd).Row            ' フォルダツリーの先頭行
    lastAdd = tsh.Cells.SpecialCells(xlCellTypeLastCell).Address(False, False, xlA1)  ' フォルダツリーの最終セル
    enRow = tsh.Range(lastAdd).Row          ' フォルダツリーの最終行
    difRow = enRow - stRow                  ' フォルダツリーの枝数 - 1

    '---- ツリー各行の階層数を取得する
    ReDim lastArr(difRow)                   ' ツリー各行の最下層列番号を格納する配列
    For lpRow = 0 To difRow
        enCol = tsh.Cells(stRow + lpRow, Columns.Count).End(xlToLeft).Column
        lastArr(lpRow) = enCol
    Next lpRow
    enColMax = xlfunc.Max(lastArr)          ' 一番深い階層数を取得
    ReDim pArr(difRow, enColMax - 1)        ' ツリー各行のフォルダパスを格納する配列

    '---- フォルダ階層を配列に格納
    For lpRow = 0 To difRow                 ' 行方向Scan
        For lpCol = 0 To lastArr(lpRow) - 1 ' 列方向Scan
            varFol = tsh.Range(stAdd).Offset(lpRow, lpCol).Value
            If varFol = "" Then
                '---- 親フォルダが空欄の時は1つ前の値を代入
                pArr(lpRow, lpCol) = pArr(lpRow - 1, lpCol)
            Else
                pArr(lpRow, lpCol) = varFol
            End If
        Next lpCol
    Next lpRow

    '---- フォルダ作成
    For lpRow = 0 To difRow
        fPath = ""
        For lpCol = 0 To lastArr(lpRow) - 1
            If lpCol = lastArr(lpRow) - 1 Then
                fPath = fPath & pArr(lpRow, lpCol)
            Else
                fPath = fPath & pArr(lpRow, lpCol) & sep
            End If
        Next lpCol
        Call SHCreateDirectoryEx(0&, fPath, 0&) '<-- フォルダ一発作成
    Next lpRow
End Sub

Sub SelectFolder()
'*****************************************************
' ルートフォルダを選択するメソッド
'*****************************************************
    Dim csh As Object
    Set csh = Sheets(SHT_CTRL)

    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then
            csh.Range(ADR_ROOT).Value = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With

End Sub

Excelシート

• controlシート
  ルートフォルダ指定のため、[...]ボタンにSelectFolderを登録してください。
  

• treeシート
  ルートフォルダ以下のツリー構成を以下の要領で記載します。階層数に制限はありません。親フォルダが同じ場合は空欄で構いません。
  

使用方法

任意名の.xlsmファイルを作成し、コードを標準モジュールにインポート(コピペ)します。
その後、シートとして"control"と"tree"を準備します。各シート内の設定は画像を参考に行ってください。
treeシートにツリー構成を記入後、controlシートでルートフォルダを指定し、実行ボタンを押します。

解説

処理の流れとしては、treeシートに記載した構成を二次元配列に格納し、SHCreateDirectoryEx APIを使用してフォルダパスを一発作成しています。
Excelシートは極力シンプルを心がけて作りました。私はデザインセンスがないのでシート内デザインはお好きなように！
treeシートは親フォルダが同じなら空欄にした方が見通しがいいので、マクロ側で工夫することで実現しました。このため、配列を複数使用したりループが多めになっています。

参考サイト

存在しないパスのフォルダを一発で作成する(Office TANAKA)