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

'----------------------------------------------------------------------
' フォルダ構成をコピー
'----------------------------------------------------------------------
' コマンドプロンプトを利用しフォルダの構成のみコピーするマクロです
' 新規フォルダはコピー元フォルダと同じフォルダに別名でコピーされます
'［作成日］2023/07/29　［更新日］2023/08/08
'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()

    'コピー元フォルダの選択
    Dim strSourceFolderPath As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "コピー元フォルダを選択してください"
        .InitialFileName = CurDir()
        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
End Sub

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