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

 

[Fluff]

Hiya
Untested, but try this.
Modifications in red

[COLOR=#ff0000]Public PFR As Workbook[/COLOR]
Sub AddStartUpPeriod()

'Click Button 1
'Declare variables
[COLOR=#ff0000]'Dim PFR As Workbook 'Create workbook object - new spreadsheet[/COLOR]
[COLOR=#ff0000]'Dim filePath As String[/COLOR]
'The file with all the PFR files are located on \PFRs
[COLOR=#ff0000]'filePath = "...\PFRs\BHMMS.xls"[/COLOR]
'Initializing
[COLOR=#ff0000]'Set PFR = Workbooks.Open(filePath)[/COLOR]
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

[COLOR=#ff0000]'Dim wb As Workbook[/COLOR]
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 [COLOR=#ff0000]PFR [/COLOR]= Workbooks.Open(Filename:=myPath & myFile)
      [COLOR=#ff0000]Call AddStartUpPeriod[/COLOR]
    'Get next file name
      myFile = Dir
  Loop
'Message Box when tasks are completed
  MsgBox "Task Complete!"
  
End Sub

 

[warradoyle]

It may not be tomorrow now until i can test this but i really appreciate you taking the time to suggest an answer.

Thanks again.

Will probably let you know if this gives me any success tomorrow.

 

[warradoyle]

Ive managed to now have no compile errors from your code so thanks for that. If you look below you can see when i click the "Populate Start Of Period" button i so far populate the BHMMS row with the respective values. In that PFR's folder is the rest of the project PFR files ie BrighT,Darwin etc.

At the moment what my code seems to do is still just populate the BHMMS row even though it seems to be looping around successfully.

Im wondering what code i need to add to populate the correct rows with the correct projects.

I imagine in my limited knowledge the reason it is doing that is that these values are currently hardcoded at the moment and therefore only populate those:
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

As you can see i need to populate each value on the correct row for its project. As ive said that PFRs folder has each project name in from 'BrighT right down to LOR'

Any idea how i can populate each project on the row it should be on like the BHMMS one is?

Many thanks for any help again.

*Edit sorry ive just failed to post an image in to show you. Will attempt this again....

 

[warradoyle]

 

[Fluff]

Sorry about that, I did this in a rush before heading home & forgot about the fact that each workbook will overwrite the previous one.
I'll have a proper look at it tomorrow.

 

[Fluff]

I've now way of testing this fully until I'm back at work, but seem ok with what little testing I can do here.

You'll need to change the path in red before running

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

    Dim PFR As Workbook
    Dim value As Currency
    Dim invoicing As Currency
    Dim cost 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

     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)
'Create dictionary & populate it with Project Names & relevant row numbers
        Set Dict = CreateObject("Scripting.Dictionary")
        a = Range("C12:C35")

        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

        PrjName = Left(myExtension, Len(myExtension) - 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")
            value = .Range("H43").value 'copy cells required h43 into value
            invoicing = .Range("H45").value 'copy h45 into invoicing
            cost = 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

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

        PFR.Close 'close the file

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

Application.ScreenUpdating = True

End Sub

 

[Fluff]

This doesn't work.
I'll be back

 

[Fluff]

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

 

[apo]

Hi...

Here's some general code that you can adapt to loop through every file (.xls my example) in a Folder (and sub folders)..

Just add what you want to do where i have put the "Do your Stuff here" comments..

Private Sub CommandButton1_Click()
    Dim z, strSource As String, strDest As String, i As Long
    Application.DisplayAlerts = False
    
    'Set Source and Destination Folder paths
    strSource = "D:\Test\": strDest = "D:\Test2\"
    
    'Put all files in Source folder into an array
    z = Split(CreateObject("wscript.shell").exec("cmd /c Dir """ & strSource & "*.xls"" /s/b").stdout.readall, vbCrLf)
    
    'Loop though the Array (loop through each file)
    For i = LBound(z) To UBound(z) - 1
    
    'Open the Workbook
        Workbooks.Open Filename:=z(i)
        
        With ActiveWorkbook
        
            ''''''''''''''''''''''''''''''''''''
            'Insert your code to do 'Stuff' here
            ''''''''''''''''''''''''''''''''''''
            
            'Close and Save the Workbook
            ActiveWorkbook.SaveAs Filename:=strDest & Split(z(i), "\")(UBound(Split(z(i), "\")))
            .Close 1
        End With
    Next i
    Application.DisplayAlerts = True
End Sub