トップ　>　汎用コード　>　フォルダ構成をコピー

'----------------------------------------------------------------------
' フォルダ構成をコピー
'----------------------------------------------------------------------
' コマンドプロンプトを利用しフォルダの構成のみコピーするマクロです
' 新規フォルダはコピー元フォルダと同じフォルダに別名でコピーされます
'［作成日］2023.07.29　［更新日］2025.04.05
' https://excel.syogyoumujou.com/vba/copy_folder_structure.html
'［参考サイト］
' https://daitaideit.com/vba-copy-only-folder-structure/
' https://kaede.jp/2014/05/31165935/
'----------------------------------------------------------------------
Sub CopyFolderStructure()

On Error GoTo LBL_ERROR

    '--------------------------
    ' コピー元フォルダの選択
    '--------------------------
    Dim strSourceFolderPath As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "コピー元フォルダを選択してください"
        If .Show Then strSourceFolderPath = .SelectedItems(1)
    End With
    If strSourceFolderPath = "" Then Exit Sub
    
    MsgBox "選択したフォルダのフォルダ構成をコピーします", vbInformation

    '--------------------------
    ' 新規フォルダの作成
    '--------------------------
    Dim lngCount         As Long
    Dim strNewFolderPath As String
    ' ファイル名生成
    Do
        lngCount = lngCount + 1
    Loop Until Dir(strSourceFolderPath & "(" & lngCount & ")", vbDirectory) = ""
    strNewFolderPath = strSourceFolderPath & "(" & lngCount & ")"
    
    ' 新規フォルダ作成
    MkDir strNewFolderPath

    '--------------------------
    ' コマンド用文字列設定
    '--------------------------
    Dim strCommand(4) As String
    strCommand(0) = "xcopy"             ' Windows　XCOPY
    strCommand(1) = "/t"                ' フォルダ構成のみをコピー（空フォルダは除く）
    strCommand(2) = "/e"                ' 空フォルダもコピー
    strCommand(3) = strSourceFolderPath ' コピー元フォルダ
    strCommand(4) = strNewFolderPath    ' コピー先フォルダ

    '--------------------------
    ' フォルダ構成をコピー
    '--------------------------
    CreateObject("WScript.Shell").Run Join(strCommand, " ")

    '--------------------------
    ' フォルダを開く
    '--------------------------
    ' コピー先フォルダの一つ上の階層フォルダ
    Shell "C:\Windows\Explorer.exe " & strNewFolderPath & "\..\", vbNormalFocus

    MsgBox "フォルダ構成をコピーしました", vbInformation
    
    Exit Sub
'--------------------------
' エラー処理
'--------------------------
LBL_ERROR:
    MsgBox "フォルダ構成のコピーに失敗しました" & vbLf & _
           "エラー番号：" & Err.Number & vbLf & _
           Err.Description, vbCritical
End Sub

【書籍紹介】知りたいがすぐわかる！　やりたいがすぐできる！
「Excel VBA 逆引きで学ぶ ユーザーフォーム&コントロール」（Kindle版）
ユーザーフォームを扱えると、VBAでできることが大きく広がります！
本書では、知りたいこと、やりたいことから、逆引きで学びを深められます。
140以上のサンプルファイル付き！