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

 

[Fluff]

If you are still having problems, I suggest that you start a new thread.