VBA Help - Code to Look into Folder Directory for File and Download to Specific Folder Location

Johnny Thunder

Well-known Member
Joined
Apr 9, 2010
Messages
693
Office Version
  1. 2016
Platform
  1. MacOS
Hello All,

I have a project which requires a tool that is capable of looking at a set list of file names, a specified sub folder and seeing if the file exists, if so, then make a copy of the file to a specific Directory and update the workbook that I will trigger the code form with a "Saved Down as of" date.

I have mocked up a quick spreadsheet with some of the test cases and not sure the best way to get this done.

A simplified explanation of steps

1. With the workbook "Download Files Tool" trigger the macro
2. Code will look at Sheet1, Range("A2:A28") for the list of Filenames and go one by one to the directory specificed in the adjacent cell
2a. Not sure if this is necessary to have the code look into a specific folder rather than looking into all subfolder of the main folder and seeing if the filename exists?
3. If the file is found, save a copy to the folder directory: C:\Users\JThunder\Downloaded Files
3a. Files can all be thrown into the same folder and do not need to be placed into sub folders, there will be no duplicate file names
4. Code will then update Column C "Saved Down As Of" with the formula =Now() and copy/Paste the date as values to log when the file was placed into the destination folder
5. The code will be triggered at various times through out the day so the code will need to look at column C, if date is blank then look for the file, if date has been populated then skip to the next filename

Unique Occurrences
1. In the event a user emails me and says they made an update to the file, I would manually delete the date in column C and re-run the tool and have the code override the saved file in the destination folder.


Hopefully the above explanation was clear.

Excel Workbook
ABC
1File NameSub Folder DirectorySaved Down as of:
2TBT v7.5 - AustraliaC:\Users\JThunder\International Reporting Package Documents\Australia8/29/2018 9:11
3TBT v7.5 - BrazilC:\Users\JThunder\International Reporting Package Documents\Brazil
4TBT v7.5 - CanadaC:\Users\JThunder\International Reporting Package Documents\Canada
5TBT v7.5 - Canada GamesC:\Users\JThunder\International Reporting Package Documents\Canada Games
6TBT v7.5 - Canada NLC:\Users\JThunder\International Reporting Package Documents\Canada NL
7TBT v7.5 - ChinaC:\Users\JThunder\International Reporting Package Documents\China
8TBT v7.5 - FranceC:\Users\JThunder\International Reporting Package Documents\France
9TBT v7.5 - Germany & AustriaC:\Users\JThunder\International Reporting Package Documents\Germany & Austria
10TBT v7.5 - Hong KongC:\Users\JThunder\International Reporting Package Documents\Hong Kong8/27/2018 11:11
11TBT v7.5 - IndiaC:\Users\JThunder\International Reporting Package Documents\India
12TBT v7.5 - ItalyC:\Users\JThunder\International Reporting Package Documents\Italy
13TBT v7.5 - JapanC:\Users\JThunder\International Reporting Package Documents\Japan
14TBT v7.5 - KoreaC:\Users\JThunder\International Reporting Package Documents\Korea8/29/2018 12:11
15TBT v7.5 - NorwayC:\Users\JThunder\International Reporting Package Documents\Norway
16TBT v7.5 - PhilippinesC:\Users\JThunder\International Reporting Package Documents\Philippines
17TBT v7.5 - PolandC:\Users\JThunder\International Reporting Package Documents\Poland
18TBT v7.5 - SingaporeC:\Users\JThunder\International Reporting Package Documents\Singapore
19TBT v7.5 - Spain & PortugalC:\Users\JThunder\International Reporting Package Documents\Spain & Portugal
20TBT v7.5 - SwedenC:\Users\JThunder\International Reporting Package Documents\Sweden
21TBT v7.5 - SwitzerlandC:\Users\JThunder\International Reporting Package Documents\Switzerland
22TBT v7.5 - TaiwanC:\Users\JThunder\International Reporting Package Documents\Taiwan
23TBT v7.5 - ThailandC:\Users\JThunder\International Reporting Package Documents\Thailand
24TBT v7.5 - TurkeyC:\Users\JThunder\International Reporting Package Documents\Turkey
25TBT v7.5 - United KingdomC:\Users\JThunder\International Reporting Package Documents\United Kingdom
26TBT v7.5 - UK ProductionsC:\Users\JThunder\International Reporting Package Documents\UK Productions
27TBT v7.5 - WBTT GamesC:\Users\JThunder\International Reporting Package Documents\WBTT Games
28TBT v7.5 - WHV (UK)C:\Users\JThunder\International Reporting Package Documents\WHV (UK)
Sheet1
 
Leith,

Here is the code in its entirety. Unfortunately even with the last modification provided I am still getting a "Runtime Error 91: Object Variable or with block not set" on the same line?

Code:
Sub SaveCopies()
'--------------------------------------------------------
'--- Searches for TBT Files within Directory
'---------------------------------------------------------
Dim cEll    As Range
Dim File    As Variant
Dim Folder  As Object
Dim Rng     As Range
Dim RngEnd  As Range
Dim Wks     As Worksheet


    Set Wks = ActiveSheet
    
    Set Rng = Wks.Range("A2")
    Set RngEnd = Wks.Cells(Rows.Count, Rng.Column).End(xlUp)
    
    If RngEnd.Row < Rng.Row Then Exit Sub Else Set Rng = Wks.Range(Rng, RngEnd)
    
    With CreateObject("Shell.Application")
        For Each cEll In Rng
            If cEll.Offset(0, 2) = Empty Then
                Set Folder = .Namespace(cEll.Offset(0, 1))
        
       
                ' // Return the file name with the extension.
                File = Dir(Folder.self.Path & "\" & cEll & "*")  '<------------------this line is still throwing an error
                
                ' // Check the file exists
                If File <> "" Then
                    File = Folder.self.Path & "\" & File
                    cEll.Offset(0, 2) = Now()
                    Set Folder = .Namespace("C:\Users\JThunder\Downloaded Files")
                    Folder.CopyHere File
                End If
            End If
        Next cEll
        
    End With
    
End Sub
 
Upvote 0

Excel Facts

Can a formula spear through sheets?
Use =SUM(January:December!E7) to sum E7 on all of the sheets from January through December
Hello Johnny,

The problem seems to be that the Folder is not found. Over the years, I have seen problems on machines where the default property for a Range object, i.e. Value, does not work unless you specify it. I have made that change to the macro along with adding a error message to alert you if the folder could not be found. Hopefully, this will solve the problems you are having.

Updated Macro Code
Code:
Sub SaveCopies()


    Dim Cell    As Range
    Dim File    As Variant
    Dim Folder  As Object
    Dim ret     As Long
    Dim Rng     As Range
    Dim RngEnd  As Range
    Dim Wks     As Worksheet
    
        Set Wks = ActiveSheet
        
        Set Rng = Wks.Range("A2")
        Set RngEnd = Wks.Cells(Rows.Count, Rng.Column).End(xlUp)
        
        If RngEnd.Row < Rng.Row Then Exit Sub Else Set Rng = Wks.Range(Rng, RngEnd)
        
        With CreateObject("Shell.Application")
            For Each Cell In Rng
                If Cell.Offset(0, 2).Value = Empty Then
                    Set Folder = .Namespace(Cell.Offset(0, 1).Value)
                    
                    ' // Check that the folder exists.
                    If Folder Is Nothing Then
                        ret = MsgBox("The Folder """ & Cell.Offset(0, 1).Value & """ was Not Found." & vbLf & "Continue?", vbYesNo)
                        If ret = vbNo Then Exit Sub
                    End If
            
                    ' // Return the file name with the extension.
                    File = Dir(Folder.self.Path & "\" & Cell.Value & "*")
                    
                    ' // Check the file exists.
                    If File <> "" Then
                        File = Folder.self.Path & "\" & File
                        Cell.Offset(0, 2).Value = Now()
                        Set Folder = .Namespace("C:\Users\JThunder\Downloaded Files")
                        Folder.CopyHere File
                    End If
                End If
            Next Cell
            
        End With


End Sub
 
Last edited:
Upvote 0
Woohoo!

This is awesome! So it is now working much better and bringing the files. A new issues is occuring and I am hoping there is a quick fix.

So currently, the scenario I am working on; I have files within folders 1-3, then for folder 4 I intentionally left it blank with no file, your "Ret" msgbox is flagging file as missing, option Yes to continue or No to exit sub. The problem is that when I select Yes, the code dims File as the missing filename and then the code crashes. Is there a way in this scenario to have the code skip the File 4 if it does not exist and continue looping thru the list of files, so in the above scenario skip and re-run code with file 5 and so on?

Hopefully the scenario makes sense how I am explaining it.

Your help has been invaluable to me and this project.
 
Upvote 0
Hello Johnny,

This version will skip over any folder that does not exist with no notification.

Code:
Sub SaveCopies()


    Dim Cell    As Range
    Dim File    As Variant
    Dim Folder  As Object
    Dim Rng     As Range
    Dim RngEnd  As Range
    Dim Wks     As Worksheet
    
        Set Wks = ActiveSheet
        
        Set Rng = Wks.Range("A2")
        Set RngEnd = Wks.Cells(Rows.Count, Rng.Column).End(xlUp)
        
        If RngEnd.Row < Rng.Row Then Exit Sub Else Set Rng = Wks.Range(Rng, RngEnd)
        
        With CreateObject("Shell.Application")
            For Each Cell In Rng
                If Cell.Offset(0, 2).Value = Empty Then
                    Set Folder = .Namespace(Cell.Offset(0, 1).Value)
                    
                    ' // Check that the folder exists.
                    If Not Folder Is Nothing Then
                        ' // Return the file name with the extension.
                        File = Dir(Folder.self.Path & "\" & Cell.Value & "*")
                    
                        ' // Check the file exists.
                        If File <> "" Then
                            File = Folder.self.Path & "\" & File
                            Cell.Offset(0, 2).Value = Now()
                            Set Folder = .Namespace("C:\Users\JThunder\Downloaded Files")
                            Folder.CopyHere File
                        End If
                    End If
            Next Cell
            
        End With


End Sub
 
Upvote 0
Hey Leith,


Thanks for all the multiple revisions. I am now getting a new error on the line Next Cell. "Compile Error: Next Without For" I tried moving things around to troubleshoot but no luck.

Hopefully this is a quick fix.
 
Upvote 0
Hello Johnny,

Sorry, my fault. There is a missing End If. This should work...

Code:
Sub SaveCopies()


    Dim Cell    As Range
    Dim File    As Variant
    Dim Folder  As Object
    Dim Rng     As Range
    Dim RngEnd  As Range
    Dim Wks     As Worksheet
    
        Set Wks = ActiveSheet
        
        Set Rng = Wks.Range("A2")
        Set RngEnd = Wks.Cells(Rows.Count, Rng.Column).End(xlUp)
        
        If RngEnd.Row < Rng.Row Then Exit Sub Else Set Rng = Wks.Range(Rng, RngEnd)
        
        With CreateObject("Shell.Application")
            For Each Cell In Rng
                If Cell.Offset(0, 2).Value = Empty Then
                    Set Folder = .Namespace(Cell.Offset(0, 1).Value)
                    
                    ' // Check that the folder exists.
                    If Not Folder Is Nothing Then
                        ' // Return the file name with the extension.
                        File = Dir(Folder.self.Path & "\" & Cell.Value & "*")
                    
                        ' // Check the file exists.
                        If File <> "" Then
                            File = Folder.self.Path & "\" & File
                            Cell.Offset(0, 2).Value = Now()
                            Set Folder = .Namespace("C:\Users\JThunder\Downloaded Files")
                            Folder.CopyHere File
                        End If
                    End If
                End If
            Next Cell
            
        End With


End Sub
 
Upvote 0
Your Awesome! that was the ticket!

All working solid now! Thanks again for spending time on this!
 
Upvote 0

Forum statistics

Threads
1,213,583
Messages
6,114,502
Members
448,575
Latest member
hycrow

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
Back
Top