Expanding VBA that gets specified data from multiple .xlsx files in specified folder

T

truerip

New Member
Joined
Feb 26, 2015
Messages
19
I have VBA that gets specific cell data from every .xlsx workbook in a specified folder (folder path is in cell A20) and places that data in different sheets of my existing workbook to allow for sorting and lookup.
What I have works great.

But how can I edit the code so it will also get the data from all subfolders as well?
Note: One subfolder deeper consists of 12 folders.
...or, can I edit the folder path in A20 someway to include multiple folder paths so that the VBA will get data from all .xlsx files in those too?

Thank you in advance for reviewing and offering assistance if you can!

Here is the code, (located in module1):

Code: 
Public Sub Get_Report_Data()
Application.ScreenUpdating = False

'Get data from files in choosen folder
'
 On Error GoTo exitloop
 Path = Sheets("Start Here").Range("A20").Value & "\"
 NextFile = Dir(Path & "*.xlsx")

 ' open book
 Workbooks.Open Filename:=Path & NextFile
 ' Copy/Paste Data from book
 Call RetrieveData
 ' Close book
 ActiveWorkbook.Close

 Do While NextFile <> "" ' Start the loop.
 NextFile = Dir
 If NextFile = "" Then Exit Sub

 ' open book
 Workbooks.Open Filename:=Path & NextFile
 ' Copy/Paste Data from book
 Call RetrieveData
 ' Close book
 ActiveWorkbook.Close

 Loop
exitloop:
 End Sub
 Private Sub RetrieveData()
 SourceSh = "Daily Report"
 TargetSh = "Sheet1"
 With ThisWorkbook.Sheets(TargetSh)
 NxtEmptyRw = .Cells(65536, 1).End(xlUp).Row + 1
 .Cells(NxtEmptyRw, 1).Value = ActiveWorkbook.Sheets(SourceSh).Range("A5").Value
 .Cells(NxtEmptyRw, 2).Value = ActiveWorkbook.Sheets(SourceSh).Range("B32").Value
 .Cells(NxtEmptyRw, 3).Value = ActiveWorkbook.Sheets(SourceSh).Range("L8").Value
 .Cells(NxtEmptyRw, 4).Value = ActiveWorkbook.Sheets(SourceSh).Range("M8").Value
 .Cells(NxtEmptyRw, 5).Value = ActiveWorkbook.Sheets(SourceSh).Range("L16").Value
 
 End With
 
  SourceSh = "Daily Report"
 TargetSh = "Sheet2"
 With ThisWorkbook.Sheets(TargetSh)
 NxtEmptyRw = .Cells(65536, 1).End(xlUp).Row + 1
 .Cells(NxtEmptyRw, 1).Value = ActiveWorkbook.Sheets(SourceSh).Range("A5").Value
 .Cells(NxtEmptyRw, 2).Value = ActiveWorkbook.Sheets(SourceSh).Range("C32").Value
 .Cells(NxtEmptyRw, 3).Value = ActiveWorkbook.Sheets(SourceSh).Range("L9").Value
 .Cells(NxtEmptyRw, 4).Value = ActiveWorkbook.Sheets(SourceSh).Range("M9").Value
 .Cells(NxtEmptyRw, 5).Value = ActiveWorkbook.Sheets(SourceSh).Range("M16").Value


End With
 
  SourceSh = "Daily Report"
 TargetSh = "Sheet3"
 With ThisWorkbook.Sheets(TargetSh)
 NxtEmptyRw = .Cells(65536, 1).End(xlUp).Row + 1
 .Cells(NxtEmptyRw, 1).Value = ActiveWorkbook.Sheets(SourceSh).Range("A5").Value
 .Cells(NxtEmptyRw, 2).Value = ActiveWorkbook.Sheets(SourceSh).Range("D32").Value
 .Cells(NxtEmptyRw, 3).Value = ActiveWorkbook.Sheets(SourceSh).Range("L10").Value
 .Cells(NxtEmptyRw, 4).Value = ActiveWorkbook.Sheets(SourceSh).Range("M10").Value
 .Cells(NxtEmptyRw, 5).Value = ActiveWorkbook.Sheets(SourceSh).Range("N16").Value

 
 End With
 
  SourceSh = "Daily Report"
 TargetSh = "Sheet4"
 With ThisWorkbook.Sheets(TargetSh)
 NxtEmptyRw = .Cells(65536, 1).End(xlUp).Row + 1
 .Cells(NxtEmptyRw, 1).Value = ActiveWorkbook.Sheets(SourceSh).Range("A5").Value
 .Cells(NxtEmptyRw, 2).Value = ActiveWorkbook.Sheets(SourceSh).Range("E32").Value
 .Cells(NxtEmptyRw, 3).Value = ActiveWorkbook.Sheets(SourceSh).Range("L11").Value
 .Cells(NxtEmptyRw, 4).Value = ActiveWorkbook.Sheets(SourceSh).Range("M11").Value
 .Cells(NxtEmptyRw, 5).Value = ActiveWorkbook.Sheets(SourceSh).Range("O16").Value

 
  End With
 
  SourceSh = "Daily Report"
 TargetSh = "Sheet5"
 With ThisWorkbook.Sheets(TargetSh)
 NxtEmptyRw = .Cells(65536, 1).End(xlUp).Row + 1
 .Cells(NxtEmptyRw, 1).Value = ActiveWorkbook.Sheets(SourceSh).Range("A5").Value
 .Cells(NxtEmptyRw, 2).Value = ActiveWorkbook.Sheets(SourceSh).Range("F32").Value
 .Cells(NxtEmptyRw, 3).Value = ActiveWorkbook.Sheets(SourceSh).Range("L12").Value
 .Cells(NxtEmptyRw, 4).Value = ActiveWorkbook.Sheets(SourceSh).Range("M12").Value
 .Cells(NxtEmptyRw, 5).Value = ActiveWorkbook.Sheets(SourceSh).Range("P16").Value

 
   End With
 
  SourceSh = "Daily Report"
 TargetSh = "Sheet6"
 With ThisWorkbook.Sheets(TargetSh)
 NxtEmptyRw = .Cells(65536, 1).End(xlUp).Row + 1
 .Cells(NxtEmptyRw, 1).Value = ActiveWorkbook.Sheets(SourceSh).Range("A5").Value
 .Cells(NxtEmptyRw, 2).Value = ActiveWorkbook.Sheets(SourceSh).Range("G32").Value
 .Cells(NxtEmptyRw, 3).Value = ActiveWorkbook.Sheets(SourceSh).Range("H32").Value
 .Cells(NxtEmptyRw, 4).Value = ActiveWorkbook.Sheets(SourceSh).Range("I32").Value


   End With
   
     SourceSh = "Daily Report"
 TargetSh = "Sheet7"
 With ThisWorkbook.Sheets(TargetSh)
 NxtEmptyRw = .Cells(65536, 1).End(xlUp).Row + 1
 .Cells(NxtEmptyRw, 1).Value = ActiveWorkbook.Sheets(SourceSh).Range("A5").Value
 .Cells(NxtEmptyRw, 2).Value = ActiveWorkbook.Sheets(SourceSh).Range("M57").Value
 .Cells(NxtEmptyRw, 3).Value = ActiveWorkbook.Sheets(SourceSh).Range("O57").Value


End With


'Application.ScreenUpdating = True


End Sub

As a side note, cell A20 is populated by code in modules 2 and 3.
Module2 lets the user browse and select a folder path and module3 pastes that selected folder path into cell A20 for module1 to use.
See that code below:

Module2:
Code: 
Option Explicit
 
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
     'Function purpose:  To Browser for a user selected folder.
     'If the "OpenAt" path is provided, open the browser at that directory
     'NOTE:  If invalid, it will open at the Desktop level
     
    Dim ShellApp As Object
     
     'Create a file browser window at the default folder
    OpenAt = "P:\Public\Broad_River\Dailies"
    Set ShellApp = CreateObject("Shell.Application"). _
    BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
     
     'Set the folder to that selected.  (On error in case cancelled)
    On Error Resume Next
    BrowseForFolder = ShellApp.self.Path
    On Error GoTo 0
     
     'Destroy the Shell Application
    Set ShellApp = Nothing
     
     'Check for invalid or non-entries and send to the Invalid error
     'handler if found
     'Valid selections can begin L: (where L is a letter) or
     '\\ (as in \\servername\sharename.  All others are invalid
    Select Case Mid(BrowseForFolder, 2, 1)
    Case Is = ":"
        If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
    Case Is = "\"
        If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
    Case Else
        GoTo Invalid
    End Select
     
    Exit Function
     
Invalid:
     'If it was determined that the selection was invalid, set to False
    BrowseForFolder = False
     
End Function

Module3:
Code: 
Public Sub CopyFolderAddress()

 Dim strChosenFolder As String
 strChosenFolder = BrowseForFolder("Choose a folder")
 'handle the click of cancel button
 If (InStr(1, LCase(strChosenFolder), LCase("false"), vbTextCompare) > 0) Then
 Exit Sub
 End If
 ActiveSheet.Range("A20") = strChosenFolder

 End Sub

Best regards!
 

Excel Facts

Which Excel functions can ignore hidden rows?
The SUBTOTAL and AGGREGATE functions ignore hidden rows. AGGREGATE can also exclude error cells and more.
Sort by date Sort by votes
Re: Need help expanding VBA that gets specified data from multiple .xlsx files in specified folder

truerip,

You might consider replacing the "Get_Report_Data" macro with the following...

Code: 
Sub StartSubfolderLoop()
Dim FolderPath As String
FolderPath = Sheets("Start Here").Range("A20").Value & "\"
SubfolderLoop FolderPath, True
End Sub

Code: 
Sub SubfolderLoop(SourceFolderName As String, IncludeSubfolders As Boolean)
' set a reference to Microsoft Scripting Runtime

Dim fso As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder
Dim SubFolder As Scripting.Folder
Dim FileItem As Scripting.File
  
Set fso = New Scripting.FileSystemObject
Set SourceFolder = fso.GetFolder(SourceFolderName)
 
For Each FileItem In SourceFolder.Files
    If InStr(FileItem.Name, ".xlsx") > 0 Then
        Workbooks.Open FileItem
        Call RetrieveData
        Workbooks(FileItem.Name).Close savechanges:=False
    End If
Next FileItem

If IncludeSubfolders Then
    For Each SubFolder In SourceFolder.SubFolders
        SubfolderLoop SubFolder.Path, True
    Next SubFolder
End If

Set FileItem = Nothing
Set SourceFolder = Nothing
Set fso = Nothing
End Sub

Cheers,

tonyyy
 
Upvote 0
Re: Need help expanding VBA that gets specified data from multiple .xlsx files in specified folder

Thanks tonyyy!
I appreciate your response. Could you advise of where I should insert your recommended code and what I should delete from my existing? btw, not sure if it matters or not but I am running Excel 2013.
Thanks,
truerip
 
Upvote 0
Re: Need help expanding VBA that gets specified data from multiple .xlsx files in specified folder

I got it working tonyyy!
Once I selected "Microsoft Scripting Runtime" under VB, Tools, References it works great.
Is there any way to edit the code to restrict depth of sub folders to 1 or better yet allow multiple folder selection?
Best regards,
trueirp
 
Upvote 0
Re: Need help expanding VBA that gets specified data from multiple .xlsx files in specified folder

Glad you got it working, truerip. The following will prompt you to enter the depth of subfolders (default = 1)...

Code: 
Sub StartSubfolderLoop()
Dim FolderPath As String, folderLevel As Long, n As Long
FolderPath = Sheets("Start Here").Range("A20").Value & "\"
folderLevel = Application.InputBox(prompt:="Please enter the depth of subfolders.", Title:="Folder Level", Default:="1")
n = 0
SubfolderLoop FolderPath, True, folderLevel, n
End Sub

Code: 
Sub SubfolderLoop(SourceFolderName As String, IncludeSubfolders As Boolean, folderLevel As Long, n As Long)
' set a reference to Microsoft Scripting Runtime
Application.ScreenUpdating = False
Dim fso As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder
Dim SubFolder As Scripting.Folder
Dim FileItem As Scripting.File
  
Set fso = New Scripting.FileSystemObject
Set SourceFolder = fso.GetFolder(SourceFolderName)
 
For Each FileItem In SourceFolder.Files
    If InStr(FileItem.Name, ".xlsx") > 0 Then
        Workbooks.Open FileItem
        Call RetrieveData
        Workbooks(FileItem.Name).Close savechanges:=False
    End If
Next FileItem

n = n + 1
If IncludeSubfolders Then
    If n <= folderLevel Then
        For Each SubFolder In SourceFolder.SubFolders
            SubfolderLoop SubFolder.Path, True, folderLevel, n
        Next SubFolder
    End If
End If

Set FileItem = Nothing
Set SourceFolder = Nothing
Set fso = Nothing
End Sub
 
Upvote 0
Re: Need help expanding VBA that gets specified data from multiple .xlsx files in specified folder

Amazing! The subfolder depth works wonderful. Only thing is the folder level prompt still runs the macro even if I select "Cancel". Haven't figured out how to make the "Cancel" selection stop the import.
How could I edit the code to set the subfolder depth to a specific value without prompting the user?
Great weekend to you!
Best regards,
truerip
 
Upvote 0
Re: Need help expanding VBA that gets specified data from multiple .xlsx files in specified folder

To enable the Cancel button and exit the macro, add the line in red...

Code: 
Sub StartSubfolderLoop()
Dim FolderPath As String, folderLevel As Long, n As Long
FolderPath = Sheets("Start Here").Range("A20").Value & "\"
folderLevel = Application.InputBox(prompt:="Please enter the depth of subfolders.", Title:="Folder Level", Default:="1")
[COLOR=#ff0000]If folderLevel = False Then Exit Sub[/COLOR]
n = 0
SubfolderLoop FolderPath, True, folderLevel, n
End Sub

To set the subfolder depth without prompting the user, change the folderLevel value in the code below...

Code: 
Sub StartSubfolderLoopr2()
Dim FolderPath As String, folderLevel As Long, n As Long
FolderPath = Sheets("Start Here").Range("A20").Value & "\"
folderLevel = 1 'Change this value
n = 0
SubfolderLoop FolderPath, True, folderLevel, n
End Sub
 
Upvote 0
Re: Need help expanding VBA that gets specified data from multiple .xlsx files in specified folder

Works perfect! Thank you for your guidance tonyyy.
Have a great one.
Best regards,
truerip
 
Upvote 0
Re: Need help expanding VBA that gets specified data from multiple .xlsx files in specified folder

You're very welcome. Glad it worked out...
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question
Accumulate Data from 10k+ Files. Very Slow. Issue with ActiveWorkbook.Sheets(2).Cells(Rows.Count, 1).End(xlUp).Row
2
Replies
10
Views
646
NdNoviceHlp
NdNoviceHlp
A
  • Question
Importing cell values from multiple workbooks in one folder
Replies
2
Views
770
Albertu95
A
B
  • Question
VBA to extract data from multiple folders and add to a master workbook plus identifying tags
Replies
2
Views
860
John_w
J
P
  • Question
Edit VBA code to add new attachment on Email
Replies
3
Views
276
Persl
P
D
  • Question
Merge Workbooks from Multiple Folders Based on by reading Order Numbers in Excel file
Replies
1
Views
482
ExcelToDAX
E

Forum statistics

Threads
1,214,982
Messages
6,122,580
Members
449,089
Latest member
Motoracer88

Share this page

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