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

I have this Excel VBA script that move files from one folder to another based on a list in Excel. However, I have to go subfolder by subfolder 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 contained in another main folder with the same folder structure as 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

How to correctly MOVE the found files from the Main Folder1 subfolders to the respective Moved2Folder subfolders?

Please note that I have posted this question on the Mr. Excel website here since last week but have not received any responses to date.

Any help will be greatly appreciated!

CodePudding user response：

Something like this should do it:

Sub CopySelected()
    
    Dim rngFileNames As Range, srcPath As String, destPath As String
    Dim colFiles As Collection, f
    
    On Error Resume Next
    Set rngFileNames = Application.InputBox("Please select the file names:", _
                   "BoBO Man", ActiveWindow.RangeSelection.Address, , , , , 8)
    On Error GoTo 0
    If rngFileNames Is Nothing Then Exit Sub
    
    srcPath = GetFolderPath("Please select the original folder:")
    If Len(srcPath) = 0 Then Exit Sub
    destPath = GetFolderPath("Please select the destination folder:")
    If Len(destPath) = 0 Then Exit Sub
    
    Set colFiles = GetMatches(srcPath, "*") 'get all source folder files
    For Each f In colFiles                  'loop source folder files
        'does the file name match one of the selected names?
        If Not IsError(Application.Match(f.Name, rngFileNames, 0)) Then
            f.Copy Replace(f.Path, srcPath, destPath) 'copy this file
        End If
    Next f
    
End Sub

'get a folder from the user - returns empty string if no selection
Function GetFolderPath(msg As String) As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = msg
        If .Show = -1 Then GetFolderPath = .SelectedItems.Item(1) & "\"
    End With
End Function

'Return a collection of file objects given a starting folder and a file pattern
'  e.g. "*.txt"
'Pass False for last parameter if don't want to check subfolders
Function GetMatches(startFolder As String, filePattern As String, _
                    Optional subFolders As Boolean = True) As Collection

    Dim fso, fldr, f, subFldr, fpath
    Dim colFiles As New Collection
    Dim colSub As New Collection
    
    Set fso = CreateObject("scripting.filesystemobject")
    colSub.Add startFolder
    
    Do While colSub.Count > 0
        
        Set fldr = fso.GetFolder(colSub(1))
        colSub.Remove 1
        
        If subFolders Then
            For Each subFldr In fldr.subFolders
                colSub.Add subFldr.Path
            Next subFldr
        End If
        
        fpath = fldr.Path
        If Right(fpath, 1) <> "\" Then fpath = fpath & "\"
        f = Dir(fpath & filePattern) 'Dir is faster...
        Do While Len(f) > 0
            colFiles.Add fso.GetFile(fpath & f)
            f = Dir()
        Loop
    Loop
    Set GetMatches = colFiles
End Function