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):
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:
Module3:
Best regards!
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!