VBA Script for moving multiple files based on an excel list

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
Stuart SmithGeneral SuperintendentAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
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 SuperintendentAuthor 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 ExpertCommented:
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.
10 Tips to Protect Your Business from Ransomware

Did you know that ransomware is the most widespread, destructive malware in the world today? It accounts for 39% of all security breaches, with ransomware gangsters projected to make $11.5B in profits from online extortion by 2019.

Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
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

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
Stuart SmithGeneral SuperintendentAuthor Commented:
Thank you so much, this will save me a lot of work.
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
You're welcome!
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
VBA

From novice to tech pro — start learning today.