MOVE files from list found in folders/subfolders to same folder structure in another folder

[johnbrownbaby]

Hello,

I have this script that move files from one folder to another based on a list in Excel. However, I have to go folder by folder to get the files. I wanted to modify the script such that it searches for the files from the main folder (that contains subfolders) and moves the respective files to the respective sub folder to another main folder with the same folder structure the original main folder.

My original folder structure is:

Main Folder1
|
|______fold1
| |_____file1.wav
| |_____file2.wav
|
|______fold2
| |_____file1.wav
| |_____file2.wav
|
|______fold3
|_____file1.wav
|_____file2.wav


This is the move to folder structure:

Moved2Folder
|
|______fold1
|
|
|
|______fold2
|
|
|
|______fold3


Here is the move 2 script that I use on individual folders:

Dim xVal As String
    On Error Resume Next
    Set xRg = Application.InputBox("Please select the file names:", "BoBO Man", ActiveWindow.RangeSelection.Address, , , , , 8)
    If xRg Is Nothing Then Exit Sub
    Set xSFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
    xSFileDlg.Title = " Please select the original folder:"
    If xSFileDlg.Show <> -1 Then Exit Sub
    xSPathStr = xSFileDlg.SelectedItems.Item(1) & "\"
    Set xDFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
    xDFileDlg.Title = " Please select the destination folder:"
    If xDFileDlg.Show <> -1 Then Exit Sub
    xDPathStr = xDFileDlg.SelectedItems.Item(1) & "\"
    For Each xCell In xRg
        xVal = xCell.Value
        If TypeName(xVal) = "String" And xVal <> "" Then
            FileCopy xSPathStr & xVal, xDPathStr & xVal
            Kill xSPathStr & xVal
        End If
    Next
End Sub

Any help will be greatly appreciated