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.
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