Quote Originally Posted by Dave View Post
I guess were going to go with copyfile then. Give this a trial. 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!"
TempRange.Offset(0, 1) = "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
sMoveFiles = True
GoTo Below
End If
Next xF
Below:
Set xFS = Nothing
Set fso = Nothing
End Function
This worked Perfectly. Thanks, I will donate to this site.