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

Bagsy

Active Member
Joined
Feb 26, 2005
Messages
424
Office Version
  1. 365
Platform
  1. Windows
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
VBA Code:
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.
VBA Code:
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
Screenshot 2021-09-27 115147.png
 

Excel Facts

How to total the visible cells?
From the first blank cell below a filtered data set, press Alt+=. Instead of SUM, you will get SUBTOTAL(9,)

Bagsy

Active Member
Joined
Feb 26, 2005
Messages
424
Office Version
  1. 365
Platform
  1. Windows
OK I have actually made a little progress
If I change the line
VBA Code:
SourcePath = R.Offset(0, 3).Value 'filepath of folder to copy from
To
VBA Code:
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
VBA Code:
FileCopy SourcePath & FName, DestPath & FName 'Copy the file 'name of file from list in (E5:E)
To
VBA Code:
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
VBA Code:
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

Active Member
Joined
Feb 26, 2005
Messages
424
Office Version
  1. 365
Platform
  1. Windows
Through trial & Error I have actually got my code to work, not quite as I envisaged and a bit slow, but working See below.
VBA Code:
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
VBA Code:
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

Active Member
Joined
Feb 26, 2005
Messages
424
Office Version
  1. 365
Platform
  1. Windows
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
 
Master Excel Bundle

Excel contains over 450 functions, with more added every year. That’s a huge number, so where should you start? Right here with this bundle.

Forum statistics

Threads
1,152,043
Messages
5,767,797
Members
425,436
Latest member
MSPaperclipMan

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top