VBA copying files from multiple subfolders according to a list

[rammy25]

Hello, I would like your help with one topic because I'm newbie to vba(copy/paste). So far I have used the code from hardipdabhi to copy pdf from one folder to another folder after a list unfortunately in the meantime have appeared many subfolders and I would like to know how I should modify the code so that the search is done in all subfolders and the copy is in one folder?

Sub movefiles()

'Updateby www.hardipdabhi.wordpress.com

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:" , "www.hardipdabhi.wordpress.com" , 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

Thank you!

 

[John_w]

copy pdf from one folder to another folder after a list unfortunately in the meantime have appeared many subfolders and I would like to know how I should modify the code so that the search is done in all subfolders and the copy is in one folder?

Try this macro:

Option Explicit

Public Sub MoveFiles()

    Dim fileNamesRange As Range, fileNameCell As Range
    Dim rootFolder As Variant, destFolder As Variant
    Dim foundFile As String
    
    On Error Resume Next
    Set fileNamesRange = Application.InputBox("Please select the file names:", "", ActiveWindow.RangeSelection.Address, , , , , Type:=8)
    On Error GoTo 0
    If fileNamesRange Is Nothing Then Exit Sub
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Please select the root folder to search:"
        If Not .Show Then Exit Sub
        rootFolder = .SelectedItems.Item(1) & "\"
    End With
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Please select the destination folder:"
        If Not .Show Then Exit Sub
        destFolder = .SelectedItems.Item(1) & "\"
    End With
    
    For Each fileNameCell In fileNamesRange
        If fileNameCell.Value <> "" Then
            foundFile = FindFile(rootFolder & fileNameCell.Value)
            If foundFile <> "" Then
                Name foundFile As destFolder & fileNameCell.Value
            Else
                MsgBox fileNameCell.Value & " not found in " & rootFolder & " and its subfolders", vbExclamation
            End If
        End If
    Next

End Sub


Private Function FindFile(filePath As String)

    Dim WSh As Object 'IWshRuntimeLibrary.WshShell
    Dim FSO As Object 'Scripting.FileSystemObject
    Dim ts As Object 'Scripting.TextStream
    Dim tempFile As String
    
    Set WSh = CreateObject("WScript.Shell") 'New IWshRuntimeLibrary.WshShell
    Set FSO = CreateObject("Scripting.FileSystemObject") 'New Scripting.FileSystemObject

    tempFile = Environ$("temp") & "\dir.txt"

    WSh.Run "cmd /c DIR /S /B " & Chr(34) & filePath & Chr(34) & " > " & Chr(34) & tempFile & Chr(34), 1, True
    
    FindFile = ""
    Set ts = FSO.OpenTextFile(tempFile)
    If Not ts.AtEndOfStream Then
        FindFile = Split(ts.ReadAll, vbCrLf)(0)
    End If
    ts.Close
        
End Function