Change existing code to give option for Move files or Copy Files

Hello smart people,


I found some clever code that works reallyl well. The only thing is that this code moves the files. Is there a way to augment this code so that it gives me an option to Move or Copy from one folder to the next. Some times I want to move and sometimes I want to just copy the file contents.

If anyone has the time to help I would appreciated.
Enjoy your weekend all!

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
    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 xCell In xRg
        xVal = xCell.Value
        If TypeName(xVal) = "String" And xVal <> "" Then
            FileCopy xSPathStr & xVal, xDPathStr & xVal
            Kill xSPathStr & xVal
        End If
    Next
End Sub

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

Greg, thank you. I just tested the code and it does what its supposed to. Thank you so much for taking the time out of your day to help me. Much appreciated!

Hi again,

Many thanks for your feedback and also for the Reputation increase - much appreciated!

You're welcome - glad I was able to help.

Best regards,

Greg M