VBA Looping through files in a folder to achieve a set task.

[warradoyle]

Hi guys. New here to VBA and Visual Basic in general. I'm really struggling to get something done with my limited knowledge.

At the moment i have some code below in the procedure AddStartUpPeriod. This code copies values (value, invoicing, cost, foreCastedValue, foreCastedCost, foreCastedInvoicing) from the Project\PFRs\BHMMS.xls sheet upon clicking my "Populate Start of Period" button.

I have been attempting unsuccessfully to make this program now do the same thing but for the rest of the .xls files i have in my PFRs folder and copy them onto the same sheet in subsequent rows. Im aware that i need to loop around the rest of the files in that PFRs folder to get it to do the same thing but have so far continued to fail at this.

My second procedure currently loops around all the files in the PFRs folder but does nothing on them. I've tried to set my second procedure to be the entry point of the program and then add a parameter to AddStartUpPeriod and then call it from the second procedure but this didnt work for me.

I think my lack of VBA knowledge in general is hindering me progressing at this point so any help would be appreciated.

To reiterate. Im pretty much trying to do what my first procedure does except i want it to do that for all the files in my PFRs folder (not just on the one BHMMS file that i have hardcoded as the filepath) by looping through them all.

Sub AddStartUpPeriod() 

'Click Button 1
'Declare variables
Dim PFR As Workbook 'Create workbook object - new spreadsheet
Dim filePath As String
'The file with all the PFR files are located on \PFRs
filePath = "...\PFRs\BHMMS.xls"
'Initializing
Set PFR = Workbooks.Open(filePath)
Dim value As Currency
Dim invoicing As Currency
Dim cost As Currency
Dim foreCastedValue As Currency
Dim foreCastedInvoicing As Currency
Dim foreCastedCost As Currency


value = PFR.Sheets("Summary").Range("H43").value 'copy cells required h43 into value
invoicing = PFR.Sheets("Summary").Range("H45").value 'copy h45 into invoicing
cost = Excel.WorksheetFunction.Sum(PFR.Sheets("Summary").Range("H40,H42")) 'copy sum of h42 and h40 into Cost
 
foreCastedValue = PFR.Sheets("Current Year & Forecast").Range("H16").value 'copy 16 into value
foreCastedInvoicing = PFR.Sheets("Current Year & Forecast").Range("H17").value 'copy 17 into invoicing
foreCastedCost = PFR.Sheets("Current Year & Forecast").Range("H15").value 'copy 15 into Cost

PFR.Close 'close the file

Sheets("Dashboard").Range("F18").value = value
Sheets("Dashboard").Range("G18").value = invoicing
Sheets("Dashboard").Range("H18").value = cost

Sheets("Dashboard").Range("L18").value = foreCastedValue
Sheets("Dashboard").Range("M18").value = foreCastedInvoicing
Sheets("Dashboard").Range("N18").value = foreCastedCost

End Sub


Sub LoopAllExcelFilesInFolder() 
'loops through all Excel files in a user specified folder and perform a set task on them

Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
'Retrieve Target Folder Path From User
  Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

    With FldrPicker
      .Title = "Select The Location of PFR files on your machine to Populate Period Start of Period From"
      .AllowMultiSelect = False
        If .Show <> -1 Then GoTo NextCode
        myPath = .SelectedItems(1) & "\"
    End With
'In Case of Cancel
NextCode:
  myPath = myPath
  If myPath = "" Then Exit Sub
'Target File Extension (must include wildcard "*")
  myExtension = "*.xls"
'Target Path with Ending Extention
  myFile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
  Do While myFile <> ""
    'Set variable equal to opened workbook
      Set wb = Workbooks.Open(Filename:=myPath & myFile)
    'Get next file name
      myFile = Dir
  Loop
'Message Box when tasks are completed
  MsgBox "Task Complete!"
  
End Sub

 

[warradoyle]

Thanks Fluff and Apo. I'm just going to look at both your suggestions and give them a whirl this morning.

Will let you know how i get on.

Thanks again for the help.

Appreciated.

 

[warradoyle]

Hi Flush. Ive followed your steps above. I assume you wanted me to completely do away with my first procedure and just use the one procedure as outlined by yourself above.

Ive also set the reference in the tools option.

I get Run Time Error 1004: Method Range of Object_Global Failed.

Currently trying to find online resources as to what the error could be.

Hopefully 3rd time lucky.
2 things you'll need to do
1) Change the file path (in red)
2) Set a reference if not already set: In the VB Editor select Tools - References - Microsoft Scripting Runtime making sure that the check box is ticked, rather than the line simply highlighted.
I have set this sub so that if a file name cannot be found in the list of project names, a new line will be created at the bottom of the list. This can easily be removed if required.

Sub LoopAllExcelFilesInFolder()

    Dim PFR As Workbook
    Dim MyValue As Currency
    Dim MyInvoicing As Currency
    Dim MyCost As Currency
    Dim foreCastedValue
    Dim foreCastedInvoicing
    Dim foreCastedCost
    Dim myPath As String
    Dim myFile As String
    Dim myExtension As String
    Dim Dict As Scripting.Dictionary
    Dim a As Variant
    Dim v As Variant
    Dim Rw As Integer
    Dim Rwnum As Integer
    Dim PrjName As String

Application.ScreenUpdating = False

'Create dictionary & populate it with Project Names & relevant row numbers
        Set Dict = CreateObject("Scripting.Dictionary")
        a = Range("C12:C48")

        With Dict
            .comparemode = vbTextCompare
            Rw = 11
            For Each v In a
                Rw = Rw + 1
    '            If Not IsEmpty(v) Then
                    If Not .Exists(v) Then .Add v, Rw
    '            End If
            Next
        End With

     myPath = "[COLOR=#ff0000]...\PFRs\[/COLOR]"
'Target File Extension (must include wildcard "*")
     myExtension = "*.xls"
'Target Path with Ending Extention
     myFile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
     Do While myFile <> ""
'Set variable equal to opened workbook
        Set PFR = Workbooks.Open(Filename:=myPath & myFile)
' Get Project name & Row number
        PrjName = Left(myFile, Len(myFile) - 4)
        If Dict.Exists(PrjName) Then
            Rwnum = Dict.Item(PrjName)
        Else
            Rwnum = Range("C" & Rows.Count).End(xlUp).Offset(1)
            Range("C" & Rwnum).value = PrjName
        End If

        With PFR.Sheets("Summary")
            MyValue = .Range("H43").value 'copy cells required h43 into value
            MyInvoicing = .Range("H45").value 'copy h45 into invoicing
            MyCost = Excel.WorksheetFunction.Sum(.Range("H40,H42")) 'copy sum of h42 and h40 into Cost
        End With

        With PFR.Sheets("Current Year & Forecast")
            foreCastedValue = .Range("H16").value 'copy 16 into value
            foreCastedInvoicing = .Range("H17").value 'copy 17 into invoicing
            foreCastedCost = .Range("H15").value 'copy 15 into Cost
        End With
        PFR.Close 'close the file

        With Sheets("Dashboard")
            .Range("F" & Rwnum).value = MyValue
            .Range("G" & Rwnum).value = MyInvoicing
            .Range("H" & Rwnum).value = MyCost
            .Range("L" & Rwnum).value = foreCastedValue
            .Range("M" & Rwnum).value = foreCastedInvoicing
            .Range("N" & Rwnum).value = foreCastedCost
        End With


'Get next file name
        myFile = Dir
    Loop
'Message Box when tasks are completed
      MsgBox "Task Complete!"

Application.ScreenUpdating = True

End Sub

 

[Fluff]

Hiya
2 things
1) have you changed the path to your files?
2) If you hit Debug when the error occurs, what line does it highlight?

 

[warradoyle]

1)Ive assigned the macro to run from LoopAllExcelFilesInFolder now but obviously i only have when procedure now (i deleted the first one as i assume the functionality is there to now do everything in this one procedure - LoolAllExcelFilesInFolder. (if that is what you mean by have i changed the path)

2)If i press debug it takes me to to the line highlighted in red:

Sub LoopAllExcelFilesInFolder()

    Dim PFR As Workbook
    Dim MyValue As Currency
    Dim MyInvoicing As Currency
    Dim MyCost As Currency
    Dim foreCastedValue
    Dim foreCastedInvoicing
    Dim foreCastedCost
    Dim myPath As String
    Dim myFile As String
    Dim myExtension As String
    Dim Dict As Scripting.Dictionary
    Dim a As Variant
    Dim v As Variant
    Dim Rw As Integer
    Dim Rwnum As Integer
    Dim PrjName As String

Application.ScreenUpdating = False

'Create dictionary & populate it with Project Names & relevant row numbers
        Set Dict = CreateObject("Scripting.Dictionary")
        a = Range("C12:C48")

        With Dict
            .comparemode = vbTextCompare
            Rw = 11
            For Each v In a
                Rw = Rw + 1
    '            If Not IsEmpty(v) Then
                    If Not .Exists(v) Then .Add v, Rw
    '            End If
            Next
        End With

     myPath = "T:\Project\ADCIS\PFRs\"
'Target File Extension (must include wildcard "*")
     myExtension = "*.xls"
'Target Path with Ending Extention
     myFile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
     Do While myFile <> ""
'Set variable equal to opened workbook
        Set PFR = Workbooks.Open(Filename:=myPath & myFile)
' Get Project name & Row number
        PrjName = Left(myFile, Len(myFile) - 4)
        If Dict.Exists(PrjName) Then
            Rwnum = Dict.Item(PrjName)
        Else
            Rwnum = Range("C" & Rows.Count).End(xlUp).Offset(1)
          [COLOR=#ff0000]  Range("C" & Rwnum).value = PrjName[/COLOR]
        End If

        With PFR.Sheets("Summary")
            MyValue = .Range("H43").value 'copy cells required h43 into value
            MyInvoicing = .Range("H45").value 'copy h45 into invoicing
            MyCost = Excel.WorksheetFunction.Sum(.Range("H40,H42")) 'copy sum of h42 and h40 into Cost
        End With

        With PFR.Sheets("Current Year & Forecast")
            foreCastedValue = .Range("H16").value 'copy 16 into value
            foreCastedInvoicing = .Range("H17").value 'copy 17 into invoicing
            foreCastedCost = .Range("H15").value 'copy 15 into Cost
        End With
        PFR.Close 'close the file

        With Sheets("Dashboard")
            .Range("F" & Rwnum).value = MyValue
            .Range("G" & Rwnum).value = MyInvoicing
            .Range("H" & Rwnum).value = MyCost
            .Range("L" & Rwnum).value = foreCastedValue
            .Range("M" & Rwnum).value = foreCastedInvoicing
            .Range("N" & Rwnum).value = foreCastedCost
        End With


'Get next file name
        myFile = Dir
    Loop
'Message Box when tasks are completed
      MsgBox "Task Complete!"

Application.ScreenUpdating = True

End Sub

Hiya
2 things
1) have you changed the path to your files?
2) If you hit Debug when the error occurs, what line does it highlight?

 

[Fluff]

OK let's try this again, now that I've corrected a couple of stupid mistakes

Sub LoopAllExcelFilesInFolder()

    Dim DshBrdSht As Worksheet
    Dim PFR As Workbook
    Dim MyValue As Currency
    Dim MyInvoicing As Currency
    Dim MyCost As Currency
    Dim foreCastedValue As Currency
    Dim foreCastedInvoicing As Currency
    Dim foreCastedCost As Currency
    Dim myPath As String
    Dim myFile As String
    Dim myExtension As String
    Dim Dict As Scripting.Dictionary
    Dim a As Variant
    Dim v As Variant
    Dim Rw As Integer
    Dim Rwnum As Integer
    Dim PrjName As String

Application.ScreenUpdating = False

     Set DshBrdSht = ActiveSheet

'Create dictionary & populate it with Project Names & relevant row numbers
        Set Dict = CreateObject("Scripting.Dictionary")
        a = Range("C12:C48")

        With Dict
            .comparemode = vbTextCompare
            Rw = 11
            For Each v In a
                Rw = Rw + 1
    '            If Not IsEmpty(v) Then
                    If Not .Exists(v) Then .Add v, Rw
    '            End If
            Next
        End With

     myPath = "T:\Project\ADCIS\PFRs\"
'Target File Extension (must include wildcard "*")
     myExtension = "*.xls"
'Target Path with Ending Extention
     myFile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
     Do While myFile <> ""
'Set variable equal to opened workbook
        Set PFR = Workbooks.Open(Filename:=myPath & myFile)
' Get Project name & Row number
        PrjName = Left(myFile, Len(myFile) - 4)
        If Dict.Exists(PrjName) Then
            Rwnum = Dict.Item(PrjName)
        Else
            Rwnum = DshBrdSht.Range("C" & Rows.Count).End(xlUp).Offset(1).Row
            DshBrdSht.Range("C" & Rwnum).Value = PrjName
        End If

        With PFR.Sheets("Summary")
            MyValue = .Range("H43").Value 'copy cells required h43 into value
            MyInvoicing = .Range("H45").Value 'copy h45 into invoicing
            MyCost = Excel.WorksheetFunction.Sum(.Range("H40,H42")) 'copy sum of h42 and h40 into Cost
        End With

        With PFR.Sheets("Current Year & Forecast")
            foreCastedValue = .Range("H16").Value 'copy 16 into value
            foreCastedInvoicing = .Range("H17").Value 'copy 17 into invoicing
            foreCastedCost = .Range("H15").Value 'copy 15 into Cost
        End With
        PFR.Close 'close the file

        With Sheets("Dashboard")
            .Range("F" & Rwnum).Value = MyValue
            .Range("G" & Rwnum).Value = MyInvoicing
            .Range("H" & Rwnum).Value = MyCost
            .Range("L" & Rwnum).Value = foreCastedValue
            .Range("M" & Rwnum).Value = foreCastedInvoicing
            .Range("N" & Rwnum).Value = foreCastedCost
        End With


'Get next file name
        myFile = Dir
    Loop
'Message Box when tasks are completed
      MsgBox "Task Complete!"

Application.ScreenUpdating = True

End Sub

If you replace the current code with this it will work, he says fingers crossed.

 

[warradoyle]

Amazing thanks for all your help. It certainly has pretty much worked except that it has begun from row 36. It needs to start from row 12 - Brighton. It has come out in the correct order and everything, as i said from the image its just started from row 36 rather than row 12.

OK let's try this again, now that I've corrected a couple of stupid mistakes

Sub LoopAllExcelFilesInFolder()

    Dim DshBrdSht As Worksheet
    Dim PFR As Workbook
    Dim MyValue As Currency
    Dim MyInvoicing As Currency
    Dim MyCost As Currency
    Dim foreCastedValue As Currency
    Dim foreCastedInvoicing As Currency
    Dim foreCastedCost As Currency
    Dim myPath As String
    Dim myFile As String
    Dim myExtension As String
    Dim Dict As Scripting.Dictionary
    Dim a As Variant
    Dim v As Variant
    Dim Rw As Integer
    Dim Rwnum As Integer
    Dim PrjName As String

Application.ScreenUpdating = False

     Set DshBrdSht = ActiveSheet

'Create dictionary & populate it with Project Names & relevant row numbers
        Set Dict = CreateObject("Scripting.Dictionary")
        a = Range("C12:C48")

        With Dict
            .comparemode = vbTextCompare
            Rw = 11
            For Each v In a
                Rw = Rw + 1
    '            If Not IsEmpty(v) Then
                    If Not .Exists(v) Then .Add v, Rw
    '            End If
            Next
        End With

     myPath = "T:\Project\ADCIS\PFRs\"
'Target File Extension (must include wildcard "*")
     myExtension = "*.xls"
'Target Path with Ending Extention
     myFile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
     Do While myFile <> ""
'Set variable equal to opened workbook
        Set PFR = Workbooks.Open(Filename:=myPath & myFile)
' Get Project name & Row number
        PrjName = Left(myFile, Len(myFile) - 4)
        If Dict.Exists(PrjName) Then
            Rwnum = Dict.Item(PrjName)
        Else
            Rwnum = DshBrdSht.Range("C" & Rows.Count).End(xlUp).Offset(1).Row
            DshBrdSht.Range("C" & Rwnum).Value = PrjName
        End If

        With PFR.Sheets("Summary")
            MyValue = .Range("H43").Value 'copy cells required h43 into value
            MyInvoicing = .Range("H45").Value 'copy h45 into invoicing
            MyCost = Excel.WorksheetFunction.Sum(.Range("H40,H42")) 'copy sum of h42 and h40 into Cost
        End With

        With PFR.Sheets("Current Year & Forecast")
            foreCastedValue = .Range("H16").Value 'copy 16 into value
            foreCastedInvoicing = .Range("H17").Value 'copy 17 into invoicing
            foreCastedCost = .Range("H15").Value 'copy 15 into Cost
        End With
        PFR.Close 'close the file

        With Sheets("Dashboard")
            .Range("F" & Rwnum).Value = MyValue
            .Range("G" & Rwnum).Value = MyInvoicing
            .Range("H" & Rwnum).Value = MyCost
            .Range("L" & Rwnum).Value = foreCastedValue
            .Range("M" & Rwnum).Value = foreCastedInvoicing
            .Range("N" & Rwnum).Value = foreCastedCost
        End With


'Get next file name
        myFile = Dir
    Loop
'Message Box when tasks are completed
      MsgBox "Task Complete!"

Application.ScreenUpdating = True

End Sub

If you replace the current code with this it will work, he says fingers crossed.

 

[Fluff]

I had a feeling something like this might happen. From your original code it looked as thought the file names matched the project names, but they obviously don't.
If we add CO0 to the initial 7 figure number of the file name, will we have the project code?

 

[warradoyle]

The files in the PFR folder are named like this:
7100033_BrightonConc_PFR_050814_Ver(01.0).xls
7100035_ALARM Support_PFR_050814_Ver(01.0).xls
7100034_Darwin P2b_PFR_04.08.14_v01.1.xls

Whilst obviously in the screenshot above the project names column they are named like:
Brighton Concourse Refurbishment
ALARM System Support
Darwin Phase 2b
It seems to use a mixture of the project name and project code column.

Perhaps i could rename the files in the PFR's folder myself to try get this to work?

<tbody>
</tbody>

I had a feeling something like this might happen. From your original code it looked as thought the file names matched the project names, but they obviously don't.
If we add CO0 to the initial 7 figure number of the file name, will we have the project code?

 

[Fluff]

7100033_BrightonConc_PFR_050814_Ver(01.0).xls

Is the project code for this CO071100033, if so I can easily tweak the code, otherwise either the filenames need to be exactly the same as the project name, or I use a different technique to get the row numbers.

 

[warradoyle]

Yes thats correct - Brighton is CO071100033. The next project down after that is CO071100034 etc which is for Darwin. If you see the project codes go down in numeric order although not necessarily iterating by one each time.

Once again Fluff thanks for the help.