Help us understand the problem. What is going on with this article?

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

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

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

作成フォルダの入力は手動でパスをコピーして入力でもいいですし、
【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

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

ワタシ流こだわり

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

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

KaoTechBlog
事務業務自動化のためVBAでプログラム作成しています。覚書用に色んな場面で使えそうなコードを載せます。コードの書き方はワタシ流です。ご了承ください。
Why not register and get more from Qiita?
  1. We will deliver articles that match you
    By following users and tags, you can catch up information on technical fields that you are interested in as a whole
  2. you can read useful information later efficiently
    By "stocking" the articles you like, you can search right away
Comments
No comments
Sign up for free and join this conversation.
If you already have a Qiita account
Why do not you register as a user and use Qiita more conveniently?
You need to log in to use this function. Qiita can be used more conveniently after logging in.
You seem to be reading articles frequently this month. Qiita can be used more conveniently after logging in.
  1. We will deliver articles that match you
    By following users and tags, you can catch up information on technical fields that you are interested in as a whole
  2. you can read useful information later efficiently
    By "stocking" the articles you like, you can search right away
ユーザーは見つかりませんでした