VBA Code to Pull Data in from Folders & Sub Folders

[Johnwyldbore]

Hello all,
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

>1.xlsx

>2.xlxs

> Sub Folder B

>3.xlsx

and so on...

Any ideas?

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
[LEFT][SIZE=14px][FONT=open sans][COLOR=rgb(44, 62, 80)]

[/LEFT]


[/COLOR][/FONT][/SIZE]

 

[juddaaaa]

You could use a recursive function like this

Sub ExtractCells(Directory As String, Optional ScreenUpdate As Boolean = True)

    Dim fso As Object, fldr As Object, subFldr As Object, fle As Object
    Dim wb As Workbook, ws As Worksheet
    Dim MySheet As String, SheetName As String, FileSpec As String
    Dim LastRow As Long
       
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fldr = fso.GetFolder(Directory)
   
    Application.ScreenUpdating = False
   
    FileSpec = "xl"
    MySheet = "DataDump"
    SheetName = "My Plan"
   
    Set wb = ThisWorkbook
    Set ws = wb.Sheets(MySheet)
   
    For Each fle In fldr
        If Left(fso.GetExtensionName(fle), 2) = FileSpec Then
            With Workbooks.Open(fle.Path)
                With .Worksheets(SheetName)
                    LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
                   
                    ws.Range("A" & LastRow + 1).Resize(1, 9).Value = _
                        Array(.[B1].Value, _
                              .[E1].Value, _
                              .[G4].Value, _
                              .[G5].Value, _
                              .[G6].Value, _
                              .[G7].Value, _
                              .[G8].Value, _
                              .[H9].Value, _
                              .[H17].Value)
                End With
               
                .Close _
                    SaveChanges:=True
            End With
        End If
    Next fle
   
    For Each subFldr In fldr.SubFolders
        ExtractCells subFldr.Path, False
    Next subFldr
   
    If ScreenUpdate Then Application.ScreenUpdating = True
   
End Sub

Call ExtractCells("C:\Users\John.wyldbore\Desktop\End of Year 2019\")

Untested, but give it a go