Help on Moving file to another folder, using partial filename

[Xtremedesign]

That changes things a bit. Trial this. Dave

Option Explicit
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, TempRange As Range
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) & "\"
For Each TempRange In xRg
If Not sMoveFiles(TempRange.Text, xSPathStr, xDPathStr) Then
MsgBox TempRange.Text & " :FILE DOESN'T EXIST!"
End If
Next TempRange
End Sub
Function sMoveFiles(xRg As String, xSPathStr As Variant, xDPathStr As Variant) As Boolean
Dim fso As Object, xF As Object, xFS As Object, TempSplit As Variant
Set fso = CreateObject("Scripting.FileSystemObject")
Set xFS = fso.GetFolder(xSPathStr)
For Each xF In xFS.Files
TempSplit = Split(xF.Name, "_")
If TempSplit(0) = CStr(xRg) Then
'copy source file to destination folder, overwrite file true/false
fso.CopyFile xSPathStr & xF.Name, xDPathStr & xF.Name, True
'remove original file
'Kill xSPathStr & xF.Name
fso.deletefile (xSPathStr & xF.Name), False
sMoveFiles = True
End If
Next xF
Set xFS = Nothing
Set fso = Nothing
End Function

The Macro works, but its hours glasses if I try to move a lot of files. Is there a code that I can add for the macro could handle moving large population of files? Thanks