VBA to Copy Pdf files from several folders to a folder on the desktop

[Bagsy]

I wonder if anybody can help a bit please.

What I am trying to achieve is to run some code to loop through the unique pdf cert nos. in column E and offset to column H to get the file path for that pdf cert then copy the cert and paste it in C:\Users\GaryBaker\Desktop\Certs\. And repeat until the end of the unique Nos list.
Also if any pdf certs are missing then highlight the unique cert No. in column E then continue to next cert number.

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 just 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.

My code so far is as below, at the moment its giving me an error “Run time error 13, type mismatch” on this line

SourcePath = R.Offset(0, 3).Value

where I am trying to offset from the list of cert nos in column E. to get the file path for each cert
And I have no clue on how I could highlight the unique No. if the cert is missing
As always all help is much appreciated.

Sub CopyCerts()
Dim R As Range
Set R = Range("E5:E204")
Dim SourcePath As String, DestPath As String, FName As String
SourcePath = R.Offset(0, 3).Value 'filepath of folder to copy from
DestPath = "C:\Users\GaryBaker\Desktop\Certs\" 'folder to copy to

'Copy Pdf certs named in list starting at "E5" from folder (File path in cell offset (0,3) from file name in "E5" list)
'then paste on desktop folder "C:\Users\user\Desktop\Certs"
'Highlight any Cert Nos. in range E that are missing

For Each R In Range("E5", Range("E" & Rows.Count).End(xlUp)) 'Check file name in each used cell in column E
FName = Dir(R.Value) 'name of file from list in (E5:E)
Do While FName <> "" 'Loop while files found
FileCopy SourcePath & FName, DestPath & FName 'Copy the file
FName = Dir() 'Search the next file
Loop
Next
MsgBox ("files copied")

End Sub

 

[Bagsy]

OK I have actually made a little progress
If I change the line

SourcePath = R.Offset(0, 3).Value 'filepath of folder to copy from

To

SourcePath = "L:\MATERIALS\Material Certification\01-PIPE & ROUND BAR\" 'filepath of folder to copy from

and hard code in a filepath

Also change this line

FileCopy SourcePath & FName, DestPath & FName 'Copy the file 'name of file from list in (E5:E)

To

FName = Dir(SourcePath & R.Value & ".pdf") 'name of file from list in (E5:E)

It will work, at least for copying from the one folder.
So can anybody please help with selecting the filepath for each folder by offsetting from the filename as it loops through the list in column E, so I can get the code to copy files from each relevant folder and also how I can highlight any file names that were missing certs.
As always, any help is appreciated

Below is the code I have got working for the one hard coded filepath

Sub CopyCerts()
Dim R As Range
Set R = Range("E5:E204")
Dim SourcePath As String, DestPath As String, FName As String
'SourcePath = R.Offset(0, 3).Value 'filepath of folder to copy from

SourcePath = "L:\MATERIALS\Material Certification\01-PIPE & ROUND BAR\"  'filepath of folder to copy from
DestPath = "C:\Users\GaryBaker\Desktop\Certs\" 'folder to copy to
    
'Copy Pdf certs named in list starting at "E5" from folder (File path in cell offset (0,3) from file name in "E5" list)
'then paste on desktop folder "C:\Users\user\Desktop\Certs"
'Highlight any Cert Nos. in range E that are missing

For Each R In Range("E5", Range("E" & Rows.Count).End(xlUp)) 'Check file name in each used cell in column E
    FName = Dir(SourcePath & R.Value & ".pdf") 'name of file from list in (E5:E)
        Do While FName <> "" 'Loop while files found
            FileCopy SourcePath & FName, DestPath & FName 'Copy the file
        FName = Dir() 'Search the next file
    Loop
Next
MsgBox ("files copied")
            
End Su

b

 

[Bagsy]

Through trial & Error I have actually got my code to work, not quite as I envisaged and a bit slow, but working See below.

Sub CopyCerts() 'copying certs
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")
            
End Sub

But I now have to change the code to search through folders & sub-folders. I have made several attempts at this, but I can’t get it to work. There may be several issues with this code but it won’t let me try anything because I am getting the error “For without Next”, I have tried everything I can to resolve this but it all ends up with errors like “Block if without end if”, End if without Block if”. I really could do with a little help if possible please. All help is always appreciated. Code below

Sub CopyCertsSubFolders() 'copying certs from folders & Sub-folders
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

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
FName = Dir(sourcePath & SubFolders & R.Value & ".pdf") 'name of file from list in (E5:E)
                
Set FSO = CreateObject("Scripting.FileSystemObject")
Set fld = FSO.GetFolder(sourcePath)

If FSO.FolderExists(fld) Then
    For Each fsoFol In FSO.GetFolder(sourcePath).SubFolders
        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")
End If
Application.ScreenUpdating = True
End Sub

 

[Bagsy]

Can anybody please help me amend my code "Sub CopyCerts" so it will search through the sub folders as well. It would be really appreciated. I have had several attempts at this and not actually made any progress at all.
Thanks in advance

Gary