Public Sub XCopy()
    Dim fmFol As String, toFol As String
    '参照元フォルダパスを文字列型変数に入れる
    fmFol = ThisWorkbook.Worksheets("XCopy").Range("B3").Value
    '参照先フォルダパスを文字列型変数に入れる
    toFol = ThisWorkbook.Worksheets("XCopy").Range("B6").Value

    If fmFol = toFol Then
        MsgBox "参照元と参照先のフォルダーパスが同一のため実行できません。"
        Exit Sub
    End If
   
   '参照元フォルダパスが\で終わる場合、終了
    If Right$(fmFol, 1) = "\" Then
        MsgBox "参照元フォルダを指定してください。"
        Exit Sub
    End If

    Dim FSO As Scripting.FileSystemObject
    Set FSO = New Scripting.FileSystemObject

    If Not (FSO.FolderExists(fmFol)) Then
        MsgBox "参照元フォルダパスが実在しません。"
        Exit Sub
    End If

    If Not (FSO.FolderExists(toFol)) Then
        MsgBox "参照先フォルダパスが実在しません。"
        Exit Sub
    End If

    '参照先フォルダパスが\で終わる場合、最後の\を除去
    If Right$(toFol, 1) = "\" Then
        toFol = Left$(toFol, Len(toFol) - 1)
    End If
      
    If MsgBox("フォルダ構成を参照元から参照先にコピーします。" & vbNewLine & _
        "よろしいですか？", vbYesNo + vbQuestion) = vbNo Then Exit Sub
   
    Dim FolderCol As Collection    'Collectionオブジェクト
    Set FolderCol = New Collection 'インスタンス化

    '参照元フォルダ構成をサーチするサブプロシージャー呼出
    RecExplorer fmFol, FSO.GetFolder(fmFol), 0, FolderCol
    Application.StatusBar = False

    '参照先フォルダにトップフォルダ作成
    If Not (FSO.FolderExists(toFol & Mid$(fmFol, InStrRev(fmFol, "\")))) Then
        'フォルダが存在しない場合に作成
        FSO.CreateFolder (toFol & Mid$(fmFol, InStrRev(fmFol, "\")))
    End If
    
    '参照先フォルダに参照元フォルダ構成コピー
    Dim sFol As Variant
    On Error GoTo ErrCheck1
    For Each sFol In FolderCol 'Collectionオブジェクトから取り出す
        If Not (FSO.FolderExists(toFol & sFol)) Then
            'フォルダが存在しない場合に作成
            FSO.CreateFolder (toFol & sFol)
        End If
    Next sFol
    On Error GoTo 0 'エラー処理を通常に戻す

    Set FolderCol = Nothing
    Set FSO = Nothing
    
    MsgBox "フォルダ構成のコピー完了。"
    
    'Explorer起動
    CreateObject("Shell.Application").Open toFol & "\"
    Exit Sub
    
ErrCheck1:
    '実行時エラー「ファイルが見つかりません。」(53)は想定内なので無視。
    '実行時エラー「パスが見つかりません。」(76)は想定内なので無視。
    'それ以外はエラーを発生させる。
    If Err.Number <> 53 And Err.Number <> 76 Then
        Err.Raise Err.Number
    End If
    Debug.Print Err.Number
    Err.Clear
    Resume Next
End Sub

Private Sub RecExplorer(ByRef fmFol As String, _
                        ByRef f As Folder, _
                        ByVal n As Integer, _
                        ByRef Col As Collection)
    Application.StatusBar = String(n * 2, "-") & f.Name
    DoEvents
    
    Dim Subf As Folder
    On Error GoTo ErrCheck2
    For Each Subf In f.SubFolders
        '見つかったフォルダパスをCollectionオブジェクトに追加
        Col.Add Mid$(fmFol, InStrRev(fmFol, "\")) & Mid$(CStr(Subf), Len(fmFol) + 1)
        '再帰呼び出し
        RecExplorer fmFol, Subf, n + 1, Col
    Next Subf
    On Error GoTo 0 'エラー処理を通常に戻す
    Exit Sub
ErrCheck2:
    '実行時エラー「書き込みできません。」(70)は想定内なので無視。
    'それ以外はエラーを発生させる。
    If Err.Number <> 70 Then
        Err.Raise Err.Number
    End If
    Debug.Print Err.Number
    Err.Clear
    On Error GoTo 0 'エラー処理を通常に戻す
End Sub