VBA 複製資料夾內的所有資料夾(不含檔案)到另一個資料夾內

想要複製資料夾內的所有資料夾，但不含檔案到另一個資料夾內

VBA Copy Folder only to another Folder

Sub Copy_Folder()

    Dim fs, f, f1, s, sf

    Dim xFiDialog As FileDialog

    Dim xFiDialog2 As FileDialog

    Dim xPath As String, xPath2 As String

    Set xFiDialog = Application.FileDialog(msoFileDialogFolderPicker)

    If xFiDialog.Show = -1 Then

        xPath = xFiDialog.SelectedItems(1)

    End If

    Set xFiDialog = Application.FileDialog(msoFileDialogFolderPicker)

    If xFiDialog.Show = -1 Then

        xPath2 = xFiDialog.SelectedItems(1)

    End If

    Set xFiDialog = Nothing

    Set fs = CreateObject("Scripting.FileSystemObject")

    Set f = fs.GetFolder(xPath)

    Set sf = f.SubFolders

    For Each f1 In sf

        If fs.FolderExists(xPath2 + "\" + f1.Name) Then

        s = s & f1.Name & " :已有資料夾" & vbCrLf

        Else

        fs.CreateFolder (xPath2 + "\" + f1.Name)

        s = s & f1.Name & " :已建立資料夾" & vbCrLf

        End If

    Next

    MsgBox s & vbCrLf & "複製資料夾完成"

End Sub