folder and subfolder vba

[ysherriff]

hello all.

i need help. i am writing a consolidation code and just need direction in opening any files in a folder and subfolder in a given directory that is .xls extension so i then can copy and paste into a summary sheet. I know how to do consolidation but i am stuck on how to search and then open all files in a folder and subfolder in a given directory that is excel based.

I know it has something to do with FileSystem Obj and Dir but I am not that well versed.

Here is my test directory where the files are:

C:\Users\yhs0004\Desktop\Various Files\3D Discover Define Drive

I have attached a screenshot as well. Thanks in advance

 

[ysherriff]

forgot the attachment

 

[ysherriff]

I found this online and see if this will work:

Sub LoopThroughFolder()
Dim folderPath As String
Dim filename As String
Dim WB As Workbook

folderPath = "C:\Orders\Dan\"

If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\"

filename = Dir(folderPath & "*.xls")
Do While filename <> ""
Set WB = Workbooks.Open(folderPath & filename)

'Call a subroutine here to operate on the just-opened workbook
Call YourMacro(WB)

WB.Close False
filename = Dir
Loop

End Sub

 

[ysherriff]

Okay. I modified the code but it is getting me a compile error saying the Loop doesn't have Do While associated with it. I do show that is not the case. Is my Do While structure inappropriate? Any help would be appreciated.

Thanks

------macro starts------
Option Explicit
Public Const ReportsFilePath = "C:\Users\yhs0004\Desktop\Various Files\3D Discover Define Drive" ' report path for consolidation
Sub Consolidate_Files_SubFolders()
Dim folderPath As String, LastRow As Long, ws As Worksheet
Dim filename As String, TargetSh As Worksheet
Dim wbTemp As Workbook, wbCons As Workbook, DestCell As Range

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Set wbCons = ThisWorkbook
Set DestCell = TargetSh.Range("A1")
Set DestCell = DestCell.Offset(1, 0)

folderPath = ReportsFilePath

If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\"

filename = Dir(folderPath & "*.xls")
Do While filename <> ""
Set wbTemp = Workbooks.Open(folderPath & filename)
Worksheets("Hospital Summary").Activate
ActiveSheet.Unprotect DrawingObjects:=True, Contents:=True, Scenarios:=True
LastRow = ws.Range("D105").End(xlUp).Row
If LastRow > 1 Then
ws.Range(Range("C6").Address & ":" & ws.Range("Q" & LastRow).Address).Copy

'activate summary workbook
wbCons.Activate
Worksheets("SharePoint Raw Data").Activate
TargetSh.Range(DestCell.Address).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Set DestCell = DestCell.Offset(LastRow - 8)

'activate temporary workbook
wbTemp.Activate
Worksheets("Hospital Summary").Activate
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True

wbTemp.Close False
filename = Dir
Loop


' Application.StatusBar = False
Sheets("SharePoint Raw Data").Select
'ProgressBox.Hide
MsgBox "Reports have consolidated successfully!", vbInformation

Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

 

[ysherriff]

I think what i might have to do is get the filename for every single file and then run the macro that way.... any suggestions??