フォルダ内にサブフォルダ作成_VBA

Question

実現したいこと

フォルダ内にサブフォルダが作成されるVBAを作成したい。
①サブフォルダ作成ツール.xlsmからVBA実行
②テスト環境フォルダ内の各フォルダ（A0001等）の中に完了フォルダが作成
●テスト環境フォルダ構成
テスト環境：対象フォルダ
ツール一覧：VBA実行ファイル格納先

●対象フォルダ構成

●実行後_フォルダ中身

前提

・②の完了フォルダを作成する際、各フォルダ（A0001等）の中に完了フォルダがあれば作成しない。
・今回フォルダ数は3個ですが、今後100個ほど増える事を想定しております。
・フォルダ内にファイル格納ケースはあるが、フォルダは完了フォルダのみの構成となる。

発生している問題・エラーメッセージ

・サブフォルダ内に完了フォルダを作成する事が出来ていないです。
・フォルダ毎に完了フォルダを作成する事が出来ていないです。

該当のソースコード

Sub フォルダ内にサブフォルダ作成()

Const copy As String = "C:\Users\○○○\Desktop\テスト環境" 'フォルダ作成上位場所
Dim objFso As Object
Set objFso = CreateObject("Scripting.FileSystemObject")

Dim strFolderPath As String

If objFso.FolderExists(copy & "\完了") Then
    MsgBox "フォルダ完了は存在しています"
Else
    strFolderPath = objFso.CreateFolder(copy & "\完了")
    MsgBox "フォルダ完了は存在しなかったので作成しました" & vbNewLine & strFolderPath
End If

Set objFso = Nothing

End Sub

Answer 1

以下のようにしてください。

Sub フォルダ内にサブフォルダ作成()

    Const copy As String = "C:\Users\○○○\Desktop\テスト環境" 'フォルダ作成上位場所
    Dim objFso As Object
    Dim s_flds As Object
    Dim fld As Object
    Dim strFolderPath As String
    Set objFso = CreateObject("Scripting.FileSystemObject")
    Set s_flds = objFso.getfolder(copy).subfolders
    For Each fld In s_flds
        strFolderPath = copy & "\" & fld.Name & "\完了"
        If objFso.FolderExists(copy & "\" & fld.Name & "\完了") Then
            MsgBox strFolderPath & "は存在しています"
        Else
            objFso.CreateFolder (copy & "\" & fld.Name & "\完了")
            MsgBox "フォルダ完了は存在しなかったので作成しました" & vbNewLine & strFolderPath
        End If
    Next
End Sub

Comments

[jabe]

迅速な対応ありがとうございます。

Answer 2

SubFoldersメソッドでサブフォルダのリストを取得できますので、それに対してForループの繰り返し処理でフォルダを作成すればいいでしょう。

Sub フォルダ内にサブフォルダ作成()

    Const TargetFld As String = "C:\Users\○○○\Desktop\テスト環境" 'フォルダ作成上位場所
    Dim objFso As Object
    Set objFso = CreateObject("Scripting.FileSystemObject")
    
    Dim objFld As Object, strFolderPath As String
    For Each objFld In objFso.GetFolder(TargetFld).SubFolders
        If objFso.FolderExists(objFld.Path & "\完了") Then
            MsgBox "フォルダ完了は存在しています"
        Else
            strFolderPath = objFso.CreateFolder(objFld.Path & "\完了")
            MsgBox "フォルダ完了は存在しなかったので作成しました" & vbNewLine & strFolderPath
        End If
    Next
    
    Set objFso = Nothing

End Sub

Comments

[jabe]

迅速な対応ありがとうございます。