Macro for copying a single file from multiple folders to one folder

Mslduth

New Member
Joined
Mar 8, 2018
Messages
3
Afternoon,

I am attempting to copy multiple files from multiple folders into one folder. I have a macro that allows me to do this from one folder to the target folder, but each time I use the macro, I have to manually select the folder for that file name, and then manually select the target file. I am looking to bypass this as I will have to update the files weekly and I have over 400 folders to go through.

Example:

Location: Folder #1
File: 01 Work Order

Location: Folder #2
File: 02 Work Order

I want to copy file "01 Work Order" and file "02 Work Order" from their respective folders to a separate folder. The current macro I am using is written as such:

Sub copyfiles()'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
End If
Next
End Sub
If more information is needed, let me know, and i'll try to grab pictures of what I want to do. Thanks!
~Mslduth
 

Some videos you may like

Excel Facts

Can you sort left to right?
To sort left-to-right, use the Sort dialog box. Click Options. Choose "Sort left to right"

Mslduth

New Member
Joined
Mar 8, 2018
Messages
3
Anyone? If what i'm trying to do is not possible, i'll try to figure something else out. Thanks!
 
L

Legacy 421546

Guest
Please rephrase your question and leave out your code.
What are you trying to accomplish?
 

VBABEGINER

Well-known Member
Joined
Jun 15, 2011
Messages
1,128
You have not specified, exactly where to paste this files..The files which need to paste, Is that goes in a particular single folder?
Anyone? If what i'm trying to do is not possible, i'll try to figure something else out. Thanks!
 

Mslduth

New Member
Joined
Mar 8, 2018
Messages
3
I have approximately 250 folders that each have a single document I want to copy over to a single folder, or even all onto an external hdd.

The problem is that over time, the information gets updated in these documents. So, I am trying to set it up so that instead of having to copy over individually, I can use a macro that would automatically save those files into the target location (external hard drive). Hope that clariifies some.
 

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
6,266
Here is a FileSystemObject procedure which recursively loops through all the subfolders starting at a common parent folder and looks for folders containing a single file and copies that file to the destination folder.
Code:
Public Sub Copy_Files()
    
    Dim FD As FileDialog
    Dim parentFolder As String, destinationFolder As String
    
    Set FD = Application.FileDialog(msoFileDialogFolderPicker)
    With FD
        .Title = "Select the common parent folder"
        If .Show = -1 Then
            parentFolder = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With
    
    With FD
        .Title = "Select the destination folder"
        If .Show = -1 Then
            destinationFolder = .SelectedItems(1) & "\"
        Else
            Exit Sub
        End If
    End With
            
    ProcessFolder parentFolder, destinationFolder
    
    MsgBox "Done"
    
End Sub


Private Sub ProcessFolder(parentFolderPath As String, destinationFolderPath As String)
    
    Static FSO As Object
    Dim thisFolder As Object
    Dim thisFile As Object
    Dim subfolder As Object
    
    If FSO Is Nothing Then Set FSO = New FileSystemObject
    
    Set thisFolder = FSO.GetFolder(parentFolderPath)
    
    If thisFolder.Files.Count = 1 Then
        For Each thisFile In thisFolder.Files
            FSO.CopyFile thisFile.Path, destinationFolderPath
        Next
    End If
    
    'Process subfolders
    
    For Each subfolder In thisFolder.subfolders
        ProcessFolder subfolder.Path, destinationFolderPath
    Next

End Sub
 
Last edited:

Watch MrExcel Video

Forum statistics

Threads
1,098,994
Messages
5,465,882
Members
406,453
Latest member
CeReaLK

This Week's Hot Topics

Top