【VBAマクロダウンロード】Excelで階層化した複数のフォルダを自動で一括作成する方法

Option Explicit

Sub CreatefoldersWithSubfolders()

    ' 変数の設定
    Dim i As Long, cmax As Long, cnt As Long, j As Long, k As Long, n1 As Long
    Dim url As String, s As String, s1 As String

    ' 開始行と列の指定
    Dim startRow As Long, startCol As Long
    startRow = 4 ' 開始行を4行目に設定
    startCol = 2 ' 開始列をB列に設定
    
    ' FileSystemObjectの設定
    Dim fs As Object
    Set fs = CreateObject("Scripting.FileSystemObject")
    
    ' 対象シートの設定
    Dim ws1 As Worksheet
    Set ws1 = ThisWorkbook.Worksheets("Sheet1") ' ThisWorkbookを使用して対象のシートを指定
    
    ' セル範囲の指定
    cmax = ws1.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    cnt = ws1.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
    
    ' フォルダパスの選択
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then
            url = .SelectedItems(1)
            ws1.Range("A2").Value = url ' フォルダパスを出力
        Else
            MsgBox "フォルダパスを選択してください。"
            Exit Sub
        End If
    End With
    
    ' Excelの記載チェック
    For i = startRow To cmax
        If Application.WorksheetFunction.CountA(ws1.Rows(i)) > 1 Then
            MsgBox "行" & i & "に複数の入力があります。入力情報を見直してください"
            Exit Sub
        End If
    Next i
    
    ' 階層別にフォルダを作成する
    On Error GoTo ErrorHandler
    For j = startCol To cnt
        For i = startRow To cmax
            If ws1.Cells(i, j).Value <> "" Then
                s1 = ws1.Cells(i, j).Value
                For k = 1 To j - startCol
                    n1 = ws1.Cells(i, j - k).End(xlUp).Row
                    s1 = ws1.Cells(n1, j - k).Value & "\" & s1
                Next k
                s = url & "\" & s1
                Call CreateFolderRecursive(fs, s)
            End If
        Next i
    Next j
    MsgBox "完了しました"
    Exit Sub
    
ErrorHandler:
    MsgBox "エラーが発生しました。処理を中断します。エラー内容：" & Err.Description & " エラーが発生したセル: " & ws1.Cells(i, j).Address
    
    ' オブジェクト解放
    Set fs = Nothing

End Sub

Sub CreateFolderRecursive(fs As Object, ByVal folderPath As String)
    Dim parentFolder As String
    parentFolder = fs.GetParentFolderName(folderPath)

    If Not fs.FolderExists(parentFolder) Then
        Call CreateFolderRecursive(fs, parentFolder)
    End If

    If Not fs.FolderExists(folderPath) Then
        fs.CreateFolder folderPath
    End If
End Sub

Dim i As Long, cmax As Long, cnt As Long, j As Long, k As Long, n1 As Longなど

startRow = 4 startCol = 2

Set fs = CreateObject("Scripting.FileSystemObject")

Set ws1 = ThisWorkbook.Worksheets("Sheet1")

cmax = ws1.Cells.Find(...) cnt = ws1.Cells.Find(...)

With Application.FileDialog(msoFileDialogFolderPicker)...

For i = startRow To cmax...

For j = startCol To cnt... Call CreateFolderRecursive(fs, s)

Sub CreateFolderRecursive(fs As Object, ByVal folderPath As String)...