VBA search subfolder and move to another folder

[accountant1234]

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

 

[shknbk2]

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

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

 

[accountant1234]

That worked flawlessly! Thank you so much for your help!!

 

[shknbk2]

You're welcome.

 

[techmonkey]

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

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,

 

[Fluff]

Try copying the code again, there were some format commands in there which I've removed.

 

[techmonkey]

Try copying the code again, there were some format commands in there which I've removed.

Thanks... it added some extra text when I copied the text.

 

[Fluff]

Are you saying it originally did that, or it's still doing that?

 

[techmonkey]

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?

 

[techmonkey]

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.