VBA Script for moving multiple files based on an excel list

Stuart Smith
Stuart Smith used Ask the Experts™
on
I have a list of documents in an excel file and want to use this list to move specific PDF files from one folder to another. Is there a script that can be produced in Excel VBA to assist in this task. Also, can the script be made so it can be used for any type of document transfer?

An example of the script requirements would be

A POP-up box would appear requesting the list range
A POP-up box would appear requesting the location of files to be transferred
A POP-up box would appear requesting destination of the files to be moved
Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
Subodh Tiwari (Neeraj)Excel & VBA Expert
Most Valuable Expert 2018
Awarded 2015

Commented:
You may give this a try...
The code assumes that the file names in the range are mentioned as file name only along with the file extension like File1.pdf etc.
You may have the different files in the range and the code will move them to the selected destination folder.

Sub MoveFiles()
Dim rngFiles As Range, aCell As Range
Dim SourceFolder As String, DestinationFolder As String
Dim fso As Scripting.FileSystemObject
Dim file As file

On Error Resume Next
'You are supposed to select the range with the file names
'Assuming file names are listed along with the file extension and without the path...
'like File1.pdf or Book1.xlsx or Test1.txt etc
Set rngFiles = Application.InputBox("Please select the range with file names.", "Select Range!", Type:=8)
On Error GoTo 0

If rngFiles Is Nothing Then
    MsgBox "You didn't select any range.", vbExclamation
    Exit Sub
End If

With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Select Source Folder!"
    .AllowMultiSelect = False
    If .Show = -1 Then
        SourceFolder = .SelectedItems(1)
    Else
        MsgBox "You didn't select the Source Folder.", vbExclamation
        Exit Sub
    End If
End With

With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Select Destination Folder!"
    .AllowMultiSelect = False
    If .Show = -1 Then
        DestinationFolder = .SelectedItems(1)
    Else
        MsgBox "You didn't select the Destination Folder.", vbExclamation
        Exit Sub
    End If
End With

Set fso = New Scripting.FileSystemObject

For Each aCell In rngFiles
    If aCell <> "" Then
        If fso.FileExists(SourceFolder & "\" & aCell.Value) Then
            Set file = fso.GetFile(SourceFolder & "\" & aCell.Value)
            If fso.FileExists(DestinationFolder & "\" & aCell.Value) Then fso.GetFile(DestinationFolder & "\" & aCell.Value).Delete
            file.Move DestinationFolder & "\"
        End If
    End If
Next aCell
Set fso = Nothing
End Sub

Open in new window

Stuart SmithGeneral Superintendent

Author

Commented:
When I went to run the code an error appeared. I have attached the spreadsheet so you may review and advise.

Thanks in advance

Stuart
Move-Files.xlsm
Subodh Tiwari (Neeraj)Excel & VBA Expert
Most Valuable Expert 2018
Awarded 2015

Commented:
What error?
BTW what range did you select? As per the existing code, you are supposed to...
1) Select the range in column A with file names.
2) Select the Source Folder where these files may exist.
3) Select the Destination Folder.

Then the code will check each file listed in column A in the selected Source Folder and if the file exists there, it will be moved to the Destination                        Folder.
Ensure you’re charging the right price for your IT

Do you wonder if your IT business is truly profitable or if you should raise your prices? Learn how to calculate your overhead burden using our free interactive tool and use it to determine the right price for your IT services. Start calculating Now!

Excel & VBA Expert
Most Valuable Expert 2018
Awarded 2015
Commented:
Never mind, I found the error. I added the reference to the Microsoft Scripting Runtime library as I used the early binding method.
Please replace the existing code with the following code which uses the late binding method so that you are not required to add the library reference.
Sub MoveFiles()
Dim rngFiles As Range, aCell As Range
Dim SourceFolder As String, DestinationFolder As String
Dim fso As Object
Dim file As Object

On Error Resume Next
'You are supposed to select the range with the file names
'Assuming file names are listed along with the file extension and without the path...
'like File1.pdf or Book1.xlsx or Test1.txt etc
Set rngFiles = Application.InputBox("Please select the range with file names.", "Select Range!", Type:=8)
On Error GoTo 0

If rngFiles Is Nothing Then
    MsgBox "You didn't select any range.", vbExclamation
    Exit Sub
End If

With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Select Source Folder!"
    .AllowMultiSelect = False
    If .Show = -1 Then
        SourceFolder = .SelectedItems(1)
    Else
        MsgBox "You didn't select the Source Folder.", vbExclamation
        Exit Sub
    End If
End With

With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Select Destination Folder!"
    .AllowMultiSelect = False
    If .Show = -1 Then
        DestinationFolder = .SelectedItems(1)
    Else
        MsgBox "You didn't select the Destination Folder.", vbExclamation
        Exit Sub
    End If
End With

Set fso = CreateObject("Scripting.FileSystemObject")

For Each aCell In rngFiles
    If aCell <> "" Then
        If fso.FileExists(SourceFolder & "\" & aCell.Value) Then
            Set file = fso.GetFile(SourceFolder & "\" & aCell.Value)
            If fso.FileExists(DestinationFolder & "\" & aCell.Value) Then fso.GetFile(DestinationFolder & "\" & aCell.Value).Delete
            file.Move DestinationFolder & "\"
        End If
    End If
Next aCell
Set fso = Nothing
End Sub

Open in new window

Stuart SmithGeneral Superintendent

Author

Commented:
Thank you so much, this will save me a lot of work.
Subodh Tiwari (Neeraj)Excel & VBA Expert
Most Valuable Expert 2018
Awarded 2015

Commented:
You're welcome!

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial