Hello, I got this code from this site but I looking to edit it. I need to edit the filename search feature. Examples in cell A2 have filename "Town" but the file in the folder is "Town_", is there a code that will read the filename before the underscores in the folder? Then move the file to the new folder.
Thank you
Sub movefiles()
'Updateby Extendoffice
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
Dim fso As Object, folder1 As Object
' On Error Resume Next
Set xRg = Application.InputBox("Please select the file names:", "KuTools For Excel", 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) & ""
Call sMoveFiles(xRg, xSPathStr, xDPathStr)
End Sub
Sub sMoveFiles(xRg As Range, xSPathStr As Variant, xDPathStr As Variant)
Dim xCell As Range
Dim xVal As String
Dim xFolder As Object
Dim fso As Object
Dim xF As Object
Dim xStr As String
Dim xFS As Object
Dim xI As Integer
On Error Resume Next
If Dir(xDPathStr, vbDirectory) = "" Then
MkDir (xDPathStr)
End If
For xI = 1 To xRg.Count
Set xCell = xRg.Item(xI)
xVal = xCell.Value
If TypeName(xVal) = "String" And Not (xVal = "") Then
On Error GoTo E1
If Dir(xSPathStr & xVal, 16) <> Empty Then
FileCopy xSPathStr & xVal, xDPathStr & xVal
Kill xSPathStr & xVal
End If
End If
E1:
Next xI
On Error Resume Next
Set fso = CreateObject("Scripting.FileSystemObject")
Set xFS = fso.GetFolder(xSPathStr)
For Each xF In xFS.SubFolders
xStr = xDPathStr & "" & xF.Name ' Replace(xF.ShortPath, xSPathStr, xDPathStr)
Call sMoveFiles(xRg, xF.ShortPath & "", xStr & "")
If (CreateObject("scripting.FileSystemObject").GetFolder(xStr).Files.Count = 0) _
And (CreateObject("scripting.FileSystemObject").GetFolder(xStr).SubFolders.Coun t = 0) Then
RmDir xStr
End If
Next
End Sub