VBAで新しいフォルダを作成するには

質問

エクセル2010です。
新しいフォルダを作成するにはMkDir関数というのはわかりますが、フォルダがなければ作る、あれば作らないようにしたいのです。
そのやりかたをお教えいただけませんでしょうか？

やりたいことは以下のようなことです。
まず、対象フォルダを指定します。
その中に多数のエクセルのBOOKがあります。
このマクロがあるBOOKのSheet1のA列に「名前リスト」があります。
名前が一致するものを、ファイルコピーして、「名前リスト」の右隣B列のセルにある「区分リスト」と同じ名前のサブフォルダ（このマクロがあるBOOKのフォルダのすぐ下です。）に貼り付ける。

ここまでは、以下のコードで少量のデータでのテストはうまくいきました。
しかし、実際には対象が1,000件近くあり、事前に作っておかなければいけないサブフォルダも何十かになります。
そこで、あらかじめサブフォルダを用意するのではなく、このマクロを作動させると自動的にサブフォルダまで作るようにできないかと欲張った質問です。

Sub TEST01()
　　Dim myPth(1) As String
　　Dim myCl As Range
　　Dim wb As Workbook

　　Set wb = ThisWorkbook
　　myPth(0) = wb.Path

　　With Application.FileDialog(msoFileDialogFolderPicker)
　　　　If .Show = True Then
　　　　　　myPth(1) = .SelectedItems(1) '対象フォルダ指定
　　　　Else
　　　　　　MsgBox "キャンセル"
　　　　　　Exit Sub
　　　　End If
　　End With

　　With wb.Sheets("Sheet1")
　　　　For Each myCl In .Range("A2:A11")
　　　　　　FileCopy myPth(1) & "\" & CStr(myCl.Value) & ".xlsx", myPth(0) & "\" & myCl.Offset(, 1).Value & "\" & CStr(myCl.Value) & ".xlsx"
　　　　　　myCl.Offset(, 2).Value = "完了"
　　　　Next myCl
　　End With

End Sub

回答No.1

MSZ006 · ベストアンサー

Dir()関数でディレクトリが存在するかどうかを確認できます。

以下は例です。

SaveDir = myPth(0) & "\" & myCl.Offset(, 1).Value
If Dir(SaveDir, vbDirectory) = "" Then
MkDir SaveDir
End If

こういったものをFileCopyの前に挿入すればどうでしょうか？

お礼

MSZ006さん、さっそくありがとうございます。
Dir関数でファイル名が取得できることは知ってましたがフォルダ名もできるんですね！
以下のようにやってみました。
おかげさまでサンプルでのテストはうまくいきました。
助かりました。ありがとうございます。

Sub Sample02()
　　Dim myPth(1) As String, SaveDir As String, Fname As String
　　Dim myCl As Range
　　Dim wb As Workbook
　　Set wb = ThisWorkbook
　　myPth(0) = wb.Path

　　With Application.FileDialog(msoFileDialogFolderPicker)
　　　　If .Show = True Then
　　　　　　myPth(1) = .SelectedItems(1) '対象フォルダ指定
　　　　Else
　　　　　　MsgBox "キャンセル"
　　　　　　Exit Sub
　　　　End If
　　End With

　　With wb.Sheets("打診先")
　　　　For Each myCl In .Range("A2:A9") '対象リスト
　　　　　　SaveDir = myPth(0) & "\" & myCl.Offset(, 1).Value 'サブフォルダ
　　　　　　If Dir(SaveDir, vbDirectory) = "" Then
　　　　　　　　MkDir SaveDir '無ければ作成
　　　　　　End If
　　　　　　Fname = Dir(myPth(1) & "\" & CStr(myCl.Value) & ".xlsx")
　　　　　　If Fname <> "" Then '念のため確認
　　　　　　　　FileCopy myPth(1) & "\" & Fname, SaveDir & "\" & Fname
　　　　　　　　myCl.Offset(, 2).Value = "完了"
　　　　　　Else
　　　　　　　　myCl.Offset(, 2).Value = "該当なし"
　　　　　　End If
　　　　Next myCl
　　End With

End Sub