VBA Code to Pull Data in from Folders & Sub Folders

Johnwyldbore

New Member
Joined
Feb 2, 2020
Messages
1
Office Version
  1. 365
Platform
  1. Windows
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.


VBA Code:
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]
 

Excel Facts

Fastest way to copy a worksheet?
Hold down the Ctrl key while dragging tab for Sheet1 to the right. Excel will make a copy of the worksheet.

juddaaaa

Board Regular
Joined
Jan 4, 2020
Messages
208
Office Version
  1. 365
Platform
  1. Windows
You could use a recursive function like this
VBA Code:
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

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

Untested, but give it a go ;)
 
Last edited:

Watch MrExcel Video

Forum statistics

Threads
1,130,137
Messages
5,640,329
Members
417,139
Latest member
madcabbie

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
Top