Hi there,
It's not really possible for me to test this properly without access to your lists of files etc., but see if the following knee-jerk additions to your code get you moving in the right direction:
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 iUserResponse As Integer
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) & "\"
iUserResponse = MsgBox("Do you want to permanently delete the original copy of each file?", _
vbYesNo + vbDefaultButton2, "Move or copy?")
For Each xCell In xRg
xVal = xCell.Value
If TypeName(xVal) = "String" And xVal <> "" Then
FileCopy xSPathStr & xVal, xDPathStr & xVal
If iUserResponse = vbYes Then
Kill xSPathStr & xVal
End If
End If
Next
End Sub
You should note that it can be extremely dangerous to insert an "open-ended" On Error Resume Next statement in a routine. As an example of what can go wrong, if under normal circumstances you try to select a worksheet which doesn't exist and then delete all of its contents, an error message will be generated - if you begin the routine with an On Error Resume Next statement, no error message will be generated and the contents of whichever worksheet happens to be active will be deleted instead!
Whenever you disable Excel's own error handling, you should re-enable it (On Error GoTo 0) as soon as possible afterwards.
Hope this helps.
Regards,
Greg M
Bookmarks