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

[Mslduth]

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

 

[Mslduth]

Anyone? If what i'm trying to do is not possible, i'll try to figure something else out. Thanks!

 

[Legacy 421546]

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

 

[VBABEGINER]

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]

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]

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.

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