【VBA】フォルダパスを指定してフォルダを一括で作成する（Dir、MkDir使用）

フォルダパスをシートに入力する

同じような名前のフォルダを大量に作成する際に使用しました。
シートに以下のように入力された新フォルダパスを作成します。

作成フォルダの入力は手動でパスをコピーして入力でもいいですし、
【VBA】ダイアログで選択したフォルダのパスをセルに入力する
の機能をつけてもいいと思います。

エラーの種類

作成フォルダが存在しない

エラー文言： "（作成フォルダパス）が存在しないため作成しませんでした"

新フォルダが既に存在している

エラー文言："新フォルダは既に存在しているため作成しませんでした"

その他何らかのエラー

フォルダに使用できない文字、256文字以上のパス、webフォルダなどの場合のネットワークエラーなど
エラー文言："指定されたパスに何らかの不正があります"

コード

今回はDirを使用してフォルダの存在確認など行っていますが
FSOでやってもいいですね。

Public Sub btnMakeFld_Click()
    If MsgBox("フォルダを作成しますか？", vbYesNo + vbQuestion, "確認") = vbYes Then
        '「はい」を選んだ場合処理開始
        Dim LastRow As Long '新フォルダ最終行格納用
        LastRow = FldSheet.Cells(Rows.Count, 3).End(xlUp).Row '最終行格納
        '処理結果を最終行までクリア
        FldSheet.Range(FldSheet.Cells(4, 2), FldSheet.Cells(4, LastRow)).ClearContents

        Dim MainFld As String '作成フォルダパス格納用
        Dim NewFldPath As String '新フォルダパス格納用
        Dim i As Long
        For i = 2 To LastRow
            MainFld = FldSheet.Cells(i, 1).Value '作成フォルダパス格納
            NewFldPath = FldSheet.Cells(i, 3).Value '新フォルダパス格納
            '行番号、作成フォルダ、新フォルダを引数として渡してフォルダ作成マクロ呼び出し
            Call FldProcess.MakeFld(i, MainFld, NewFldPath)
        Next i
        MsgBox "処理が完了しました ＼(´∀｀)／" & vbCrLf & _
               "処理結果を確認してください。"
     Else
      '「いいえ」を選んだ場合処理中止
        MsgBox "処理を中断します　(>_<)"
    End If
End Sub

'=========================================
'フォルダ作成処理
'=========================================
Public Sub MakeFld(i As Long, MainFld As String, NewFldPath As String)
'＝＝＝＝作成フォルダが存在してるか確認
    Dim MainFldChk As String '1階層前のフォルダ存在確認用
    MainFldChk = Dir(MainFld, vbDirectory) '作成フォルダの存在確認
    If Len(MainFldChk) <> 0 Then
'＝＝＝＝新フォルダが既に存在してるか確認
        Dim NewFldChk As String
        NewFldChk = Dir(NewFldPath, vbDirectory) '作成フォルダの存在確認
            If Len(NewFldChk) = 0 Then '新フォルダが存在しなけMainFldば
                On Error GoTo eh
                MkDir NewFldPath '新フォルダを作る
                On Error GoTo 0
                FldSheet.Cells(i, 4).Value = "〇" '成功として〇を記載
            Else ''新フォルダが存在したらエラー内容を処理結果に書き込み
                FldSheet.Cells(i, 4).Value = "新フォルダは既に存在しているため作成しませんでした"
            End If
'＝＝＝＝
    Else '作成フォルダが存在しなかったらエラー内容を処理結果に書き込み
        FldSheet.Cells(i, 4).Value = MainFld & "が存在しないため作成しませんでした"
    End If
'＝＝＝＝
    Exit Sub
eh: '処理中に予期せぬエラーが起きたらここにスキップしてエラー内容を処理結果に書き込み
    FldSheet.Cells(i, 4).Value = "指定されたパスに何らかの不正があります"
End Sub

【実行結果】


ローカルだと一瞬でたくさん作成出来ます。
社内のwebフォルダ上ではもう少し時間がかかるのと、ネットワークが途切れたりするのが原因なのか、MkDirでエラーになることがまれに起こりました。
もう一度やり直すと正常に作成できるので、そのようなエラーが起きた場合は再度実行するようにしました。

ワタシ流こだわり

ファイルやフォルダを扱う際にDir派とFSO派に別れますがワタシはどっちも使ってます。
FSOのほうが回避できるエラーも多く利点も多いのかも。
存在確認だけとかならめんどくさいのでDirで済ましてしまいます。

別の機会にFSOを使ったファイル操作のコードを書き残したいと思います。