Option Explicit
Sub GatherData()
Range("E1").Value = "Quoted By"
Range("F1").Value = "Client Name"
Range("G1").Value = "Email"
Dim sFolder As String
Application.ScreenUpdating = True
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & "\"
.Title = "Please select a folder..."
.Show
If .SelectedItems.Count > 0 Then
sFolder = .SelectedItems(1) & "\"
Else
Exit Sub
End If
End With
Call Consolidate(sFolder, ThisWorkbook)
End Sub
Private Sub Consolidate(sFolder As String, wbMaster As Workbook)
Dim wbTarget As Workbook
Dim ary(3) As Variant
Dim lRow As Long
Dim objFile As Object
Dim objFso As Object
Dim objFiles As Object
Dim objSubFolders As Object
Dim objSubFolder As Object
Set objFso = CreateObject("Scripting.FileSystemObject")
Set objFiles = objFso.GetFolder(sFolder).Files
Dim CodeNames As Variant, i As Long
CodeNames = Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row)
For Each objFile In objFiles
For i = 1 To UBound(CodeNames, 1)
If objFile.Name Like "*" & CodeNames(i, 1) & "*" Then
'Create objects to enumerate files and folders
Set objFso = CreateObject("Scripting.FileSystemObject")
Set objSubFolders = objFso.GetFolder(sFolder).subFolders
Set objFiles = objFso.GetFolder(sFolder).Files
'Loop through each file in the folder
If InStr(1, objFile.Path, ".xls") > 0 Then
Set wbTarget = Workbooks.Open(objFile.Path)
With wbTarget.Worksheets(1)
ary(0) = .Range("B8")
ary(1) = .Range("B12")
ary(2) = .Range("B14")
End With
With wbMaster.Worksheets(1)
lRow = .Range("E" & .Rows.Count).End(xlUp).Offset(1, 0).Row
.Range("E" & lRow & ":G" & lRow) = ary
End With
wbTarget.Close savechanges:=False
End If
'Request count of files in subfolders
For Each objSubFolder In objSubFolders
Consolidate objSubFolder.Path, wbMaster
Next objSubFolder
Exit For
'else statement goes here
End If
Next i
Next objFile
End Sub