I was wondering if anybody could help. I have the following code which looks at a folder location (Directory = "C:\Users\John.wyldbore\Desktop\End of Year 2019\") and pulls in specific cell data from any spreadsheets within that location. How can I change this so it also includes any sub folders within that location as well please?
C:\Users\John.wyldbore\Desktop\End of Year 2019\
> Sub Folder A
> Sub Folder B
and so on...
Thank you in advance.
Sub ExtractCells() ' local wb vars Dim WB As Workbook Dim ws As Worksheet Dim MySheet As String Dim r1 As Range Dim r2 As Range Dim r3 As Range Dim r4 As Range Dim r5 As Range Dim r6 As Range Dim r7 As Range Dim r8 As Range Dim r9 As Range Dim I As Integer ' open file Dim OpenWorkbook As Workbook Dim OpenWorksheet As Worksheet Dim SheetName As String ' Stop screen flashing Application.ScreenUpdating = False ' looping Dim Directory As String Dim FileSpec As String Dim MyFile As String ' file location Directory = "C:\Users\John.wyldbore\Desktop\End of Year 2019\" FileSpec = ".xl??" 'File extension MyFile = Dir(Directory & "*" & FileSpec) SheetName = "My Plan" 'Should be correct ' Related to this sheet Set WB = ThisWorkbook MySheet = "DataDump" 'Should be correct Set ws = WB.Worksheets(MySheet) ' This is where data will begin to write Set r1 = ws.Range("A2") Set r2 = ws.Range("B2") Set r3 = ws.Range("C2") Set r4 = ws.Range("D2") Set r5 = ws.Range("E2") Set r6 = ws.Range("F2") Set r7 = ws.Range("G2") Set r8 = ws.Range("H2") Set r9 = ws.Range("I2") I = 0 Do While MyFile <> "" Set OpenWorkbook = Application.Workbooks.Open(Filename:=Directory & MyFile, ReadOnly:=True) Set OpenWorksheet = OpenWorkbook.Worksheets(SheetName) ' Cells data copied from With OpenWorksheet r1.Offset(I, 0).Value = .Range("B1").Value r2.Offset(I, 0).Value = .Range("E1").Value r3.Offset(I, 0).Value = .Range("G4").Value r4.Offset(I, 0).Value = .Range("G5").Value r5.Offset(I, 0).Value = .Range("G6").Value r6.Offset(I, 0).Value = .Range("G7").Value r7.Offset(I, 0).Value = .Range("G8").Value r8.Offset(I, 0).Value = .Range("H9").Value r9.Offset(I, 0).Value = .Range("H17").Value End With I = I + 1 MyFile = Dir Loop Windows("MyPlan Master v0.1 - Copy.xlsm").Activate 'Will need changing if this document is renamed Application.DisplayAlerts = False Application.ScreenUpdating = False For Each WB In Application.Workbooks If WB.Name <> ThisWorkbook.Name Then WB.Close savechanges:=True End If Next Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub