Copy files from sub folders-CodePudding

From Rows 5 to 204
Column B is just numbering the rows
In column C Have a list of pdf file names (these are pdf certs)
I run a bit of code and it filters the unique values from column C to column E and sorts A-Z
Column G has the formula =IF(E5="","",LEFT(E5,2)) to get the file index No.
Column H has the formula =IF(E5="","",VLOOKUP(G5 0,$I$5:$J$11,2,FALSE)) to get the file path for the folders where the certs are Columns I & J are the Lookup table.

I put together code which will loop down the list of cert numbers in column E and then offset(0,3) to column H where the folder file-path for that cert is. It then goes to that folder copies that particular file into a folder on my desktop, then carries on down the list in column E offsetting to the file-path until it reaches the end of the cert numbers in column E, any files that are missing it highlights in red.

Sub CopyCerts() 'copying certs
    Application.ScreenUpdating = False
    Dim R As Range
    Set R = Range("E5:E204")
    Dim SourcePath As String, DestPath As String, FName As String, FileExists As String
    DestPath = "C:\Users\GaryBaker\Desktop\Certs\" 'folder to copy to
    
    For Each R In Range("E5", Range("E" & Rows.Count).End(xlUp)) 'Check file name in each used cell in column E
        R.Offset(0, 3).Activate
        SourcePath = ActiveCell.Value
        FileExists = Dir(SourcePath & R.Value & ".pdf") 'checking if the cert exists
        FName = Dir(SourcePath & R.Value & ".pdf") 'name of file from list in (E5:E)
        If FileExists = "" Then 'If the file does not exist highlight in red, else copy
            ActiveCell.Offset(0, -3).Font.Color = vbRed 'Highlight any Cert Nos. in range E that are missing
        Else
            FileCopy SourcePath & FName, DestPath & FName 'Copy the file
        End If
        Do While FName <> "" 'Loop while files found
            FName = Dir() 'Search the next file
        Loop
    Next
    MsgBox ("files copied")
    Application.ScreenUpdating = True
End Sub

I need to modify the code so it will search the subfolders of each main folder as well.

I had several attempts to cobble together some code. I keep getting errors “For without Next”, “Block if without end if”, End if without Block if” etc.

Sub CopyCertsSubFolders() 'copying certs
    Application.ScreenUpdating = False
    Dim R As Range
    Set R = Range("E5:E204")
    Dim SourcePath As String, DestPath As String, FName As String, FileExists As String, FSO As Object, fld As Object, FSOFile As Object, fsoFol As Object
    DestPath = "C:\Users\GaryBaker\Desktop\Certs\" 'folder to copy to
    
    If Right(SourcePath, 1) <> "\" Then
        SourcePath = SourcePath & "\"
    End If
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set fld = FSO.GetFolder(SourcePath)
    If FSO.FolderExists(fld) Then
    End If
    'For Each fsoFol In FSO.GetFolder(SourcePath).subfolders
    'For Each FSOFile In fsoFol.Files
    
    For Each R In Range("E5", Range("E" & Rows.Count).End(xlUp)) 'Check file name in each used cell in column E
        R.Offset(0, 3).Activate
        SourcePath = ActiveCell.Value
        FileExists = Dir(SourcePath & subfolders & R.Value & ".pdf") 'checking if the cert exists in folders & sub-folders
        FName = Dir(SourcePath & subfolders & R.Value & ".pdf") 'name of file from list in (E5:E)
    
        If FileExists = "" Then 'If the file does not exist highlight in red, else copy
            ActiveCell.Offset(0, -3).Font.Color = vbRed 'Highlight any Cert Nos. in range E that are missing
        Else
            FileCopy SourcePath & FName, DestPath & FName 'Copy the file
        End If
                
        Do While FName <> "" 'Loop while files found
            FName = Dir() 'Search the next file
        Loop
    Next
    MsgBox ("files copied")
    Application.ScreenUpdating = True
End Sub

CodePudding user response：

Tim As comment the code does not find or copy any files. Please see the code below

    Sub CopyCertsSubFolders() 'copying certs
Application.ScreenUpdating = False
Dim R As Range
Set R = Range("E5:E204")
Dim ws As Worksheet, foundFile
Set ws = ActiveSheet
DestPath = "C:\Users\GaryBaker\Desktop\Certs\" 'folder to copy to

For Each R In ws.Range("E5", ws.Range("E" & Rows.Count).End(xlUp)).Cells
    foundFile = MatchFirstFile(R.Offset(0, 3).Value, R.Value & ".pdf") 'call the function 'for first match
        If Len(foundFile) = 0 Then
            R.Font.Color = vbRed 'Highlight any Cert Nos. in range E that are missing
        Else
    FileCopy foundFile, DestPath & R.Value & ".pdf" 'Copy the file
End If

Next R
MsgBox ("files copied")

 Application.ScreenUpdating = True
End Sub

And Below

'Find the first file in `startFolder` (or subfolders of that location) which
'  matches `filePattern`
Function MatchFirstFile(startFolder As String, filePattern As String) As String
    Dim colSub As New Collection, f, fld
    colSub.Add startFolder
    Do While colSub.Count > 0
        fld = colSub(1)
        colSub.Remove 1
        f = Dir(fld, vbDirectory)
        Do While Len(f) > 0
            If GetAttr(fld & f) = vbDirectory Then
                If f <> "." And f <> ".." Then 'ignore parent and current folders
                    colSub.Add fld & f & "\"
                End If
            Else
                If UCase(f) Like UCase(filePattern) Then
                    MatchFile = fld & f
                    Exit Function
                End If
            End If
            f = Dir()
        Loop
    Loop
End Function

CodePudding user response：

This function will return the first matching file path, given a folder to start in and an exact or partial file name (use * as wildcard if required).

'Find the first file in `startFolder` (or subfolders of that location) which
'  matches `filePattern`
Function MatchFirstFile(startFolder As String, filePattern As String) As String
    Dim colSub As New Collection, f, fld
    colSub.Add startFolder
    Do While colSub.Count > 0
        fld = colSub(1)
        colSub.Remove 1
        f = Dir(fld, vbDirectory)
        Do While Len(f) > 0
            If GetAttr(fld & f) = vbDirectory Then
                If f <> "." And f <> ".." Then 'ignore parent and current folders
                    colSub.Add fld & f & "\"
                End If
            Else
                Debug.Print "File: " & fld & f   'EDIT
                If UCase(f) Like UCase(filePattern) Then
                    MatchFile = fld & f
                    Exit Function
                End If
            End If
            f = Dir()
        Loop
    Loop
End Function

You can try modifying your code to call the function:

Dim ws As Worksheet, foundFile

Set ws = ActiveSheet

For Each R In ws.Range("E5", ws.Range("E" & Rows.Count).End(xlUp)).Cells
    
    foundFile = MatchFirstFile(R.Offset(0, 3).Value, R.Value & ".pdf") 'call the function
                                                                       'for first match
    
    If Len(foundFile) = 0 Then
        R.Offset(0, 3).Font.Color = vbRed 'Highlight any Cert Nos. in range E that are missing
    Else
        FileCopy foundFile, DestPath & R.Value & ".pdf" 'Copy the file
    End If
    
Next R