VBA search subfolder and move to another folder

accountant1234

New Member
Joined
Sep 19, 2019
Messages
2
Hi All,

Long time lurker but first time poster. I have a scenario where I'd like to use a list in Excel to search for and copy the corresponding files to another folder. I believe I have most of the code written and it seems to work fine except for two small issues. One issue is that I need to be able to search the subfolders. Right now, it only searches the main folder identified and not the many subfolders beneath. The other issue is that it needs to search for partial matches. Right now, it only searches for exact matches including file extension. I would like it to move the file if it contains the words from the list. Below is the current code I have. Any help would be much appreciated. Thank you!

Sub copyfiles()
'Updateby JHey
Dim xRg As Range, xCell As Range
Dim xSFileDlg As FileDialog, xDFileDlg As FileDialog
Dim xSPathStr As Variant, xDPathStr As Variant
Dim xVal As String
On Error Resume Next
Set xRg = Application.InputBox("Please select the file names:", "JHey", 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
End If
Next
End Sub
 

Excel Facts

Ambidextrous Undo
Undo last command with Ctrl+Z or Alt+Backspace. If you use the Undo icon in the QAT, open the drop-down arrow to undo up to 100 steps.
Welcome to the forum.

Let's start with this and see how close it gets you. The code finds the first file to match the xVal text and moves that to the destination folder. Then, it moves on to the next xVal. If you need it to find all occurences, then we'll need to change the code. I've put the code in blue to indicate what's different in your original Sub routine. Obviously, all text outside of your original routine is new.

I borrowed some code for the recursion of the folders from HERE.

This code uses early binding, so you need to set a reference to Microsoft Scripting Runtime in the VB Editor:
1) click Tools, References
2) search the list (alphabetical order) until you find Microsoft Scripting Runtime
3) check the box and click OK


Rich (BB code):
Dim blNotFirstIteration As BooleanDim Fil As File
Dim hFolder As Folder, SubFolder As Folder
Dim NameOfFile As String
Dim FSO As Scripting.FileSystemObject

Sub copyfiles()
'Updateby JHey
    Dim xRg As Range, xCell As Range
    Dim xSFileDlg As FileDialog, xDFileDlg As FileDialog
    Dim xSPathStr As Variant, xDPathStr As Variant
    Dim xVal As String
    On Error Resume Next
    Set xRg = Application.InputBox("Please select the file names:", "JHey", 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
        blNotFirstIteration = False
        NameOfFile = ""
        xVal = xCell.Value
        If TypeName(xVal) = "String" And xVal <> "" Then
            FindFilesInFolders xSPathStr, xVal
            If NameOfFile <> "" Then
                FileCopy Fil.Path, xDPathStr & "\" & NameOfFile
            End If
        End If
    Next
End Sub

Sub FindFilesInFolders(ByVal HostFolder As String, FileName As String)
    If NameOfFile <> "" Then Exit Sub

    If FSO Is Nothing Then Set FSO = New Scripting.FileSystemObject
    Set hFolder = FSO.GetFolder(HostFolder)

    ' iterate through all files in the root of the main folder
    If Not blNotFirstIteration Then
      For Each Fil In hFolder.Files
          If InStr(1, FSO.GetFileName(Fil.Path), FileName) > 0 Then
              NameOfFile = FSO.GetFileName(Fil.Path)
              Exit Sub
          End If
      Next Fil
   
      ' make recursive call, if main folder contains subfolder
      If Not hFolder.SubFolders Is Nothing Then
          blNotFirstIteration = True
          Call FindFilesInFolders(HostFolder, FileName)
          If NameOfFile <> "" Then Exit Sub
      End If
   
    ' iterate through all files in all the subfolders of the main folder
    Else
      For Each SubFolder In hFolder.SubFolders
            For Each Fil In SubFolder.Files
                If InStr(1, FSO.GetFileName(Fil.Path), FileName) > 0 Then
                     NameOfFile = FSO.GetFileName(Fil.Path)
                     Exit Sub
                 End If
          Next Fil
   
          ' make recursive call, if subfolder contains subfolders
          If Not SubFolder.SubFolders Is Nothing Then
              Call FindFilesInFolders(HostFolder & "\" & SubFolder.Name, FileName)
              If NameOfFile <> "" Then Exit Sub
          End If
      Next SubFolder
    End If
    blNotFirstIteration = False
End Sub
 
Last edited by a moderator:
Upvote 0
Welcome to the forum.

Let's start with this and see how close it gets you. The code finds the first file to match the xVal text and moves that to the destination folder. Then, it moves on to the next xVal. If you need it to find all occurences, then we'll need to change the code. I've put the code in blue to indicate what's different in your original Sub routine. Obviously, all text outside of your original routine is new.

I borrowed some code for the recursion of the folders from HERE.

This code uses early binding, so you need to set a reference to Microsoft Scripting Runtime in the VB Editor:
1) click Tools, References
2) search the list (alphabetical order) until you find Microsoft Scripting Runtime
3) check the box and click OK


Code:
Dim blNotFirstIteration As BooleanDim Fil As File
Dim hFolder As Folder, SubFolder As Folder
Dim NameOfFile As String
Dim FSO As Scripting.FileSystemObject

Sub copyfiles()
'Updateby JHey
    Dim xRg As Range, xCell As Range
    Dim xSFileDlg As FileDialog, xDFileDlg As FileDialog
    Dim xSPathStr As Variant, xDPathStr As Variant
    Dim xVal As String
    On Error Resume Next
    Set xRg = Application.InputBox("Please select the file names:", "JHey", 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
        [COLOR=#0000ff]blNotFirstIteration = False
        NameOfFile = ""[/COLOR]
        xVal = xCell.Value
        If TypeName(xVal) = "String" And xVal <> "" Then
            [COLOR=#0000ff]FindFilesInFolders xSPathStr, xVal
            If NameOfFile <> "" Then[/COLOR]
                FileCopy [COLOR=#0000ff]Fil.Path[/COLOR], xDPathStr [COLOR=#0000ff]& "\" & NameOfFile[/COLOR]
           [COLOR=#0000ff] End If[/COLOR]
        End If
    Next
End Sub

Sub FindFilesInFolders(ByVal HostFolder As String, FileName As String)
    If NameOfFile <> "" Then Exit Sub

    If FSO Is Nothing Then Set FSO = New Scripting.FileSystemObject
    Set hFolder = FSO.GetFolder(HostFolder)

    ' iterate through all files in the root of the main folder
    If Not blNotFirstIteration Then
      For Each Fil In hFolder.Files
          If InStr(1, FSO.GetFileName(Fil.Path), FileName) > 0 Then
              NameOfFile = FSO.GetFileName(Fil.Path)
              Exit Sub
          End If
      Next Fil
   
      ' make recursive call, if main folder contains subfolder
      If Not hFolder.SubFolders Is Nothing Then
          blNotFirstIteration = True
          Call FindFilesInFolders(HostFolder, FileName)
          If NameOfFile <> "" Then Exit Sub
      End If
   
    ' iterate through all files in all the subfolders of the main folder
    Else
      For Each SubFolder In hFolder.SubFolders
            For Each Fil In SubFolder.Files
                If InStr(1, FSO.GetFileName(Fil.Path), FileName) > 0 Then
                     NameOfFile = FSO.GetFileName(Fil.Path)
                     Exit Sub
                 End If
          Next Fil
   
          ' make recursive call, if subfolder contains subfolders
          If Not SubFolder.SubFolders Is Nothing Then
              Call FindFilesInFolders(HostFolder & "\" & SubFolder.Name, FileName)
              If NameOfFile <> "" Then Exit Sub
          End If
      Next SubFolder
    End If
    blNotFirstIteration = False
End Sub
I'm seeing some errors like "Dim blNotFirstIteration As BooleanDim Fil As File" in the code.

I was able to fix this one:
Dim blNotFirstIteration As Boolean
Dim Fil As File
Dim hFolder As Folder, SubFolder As Folder
Dim NameOfFile As String
Dim FSO As Scripting.FileSystemObject

but I'm trying to fix the other errors and can't seem to find what is wrong:

For Each xCell In xRg
blNotFirstIteration = False
NameOfFile = ""

xVal = xCell.Value
If TypeName(xVal) = "String" And xVal <> "" Then
FindFilesInFolders xSPathStr, xVal
If NameOfFile <> "" Then

FileCopy Fil.Path, xDPathStr & "\" & NameOfFile
End If
End If

Thanks,
 
Upvote 0
Try copying the code again, there were some format commands in there which I've removed.
 
Upvote 0
Are you saying it originally did that, or it's still doing that?
 
Upvote 0
I'm new at writing code and I noticed if the file name in excel doesn't have a matching file name, it will freeze up. Any idea on how to make it copy file only if the file name has a matching file using the code above?
 
Upvote 0
Are you saying it originally did that, or it's still doing that?
The 1st time I copied the text something got added... I was able copy it again and it was correct. Might have been how I copied the text over.
 
Upvote 0

Forum statistics

Threads
1,213,536
Messages
6,114,211
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top