Loop through folder to fill a table

I am trying to loop through an entire folder, opening each file in the folder and getting data from the same seven cells in each file and filling a table with the data. The code I have below only takes me to select one file and then fills only the top row of the table.

Sub Data()
Set wb1 = ActiveWorkbook
ChDrive "F"
ChDir "F:\Stuff\SPECIAL PROJECTS\More Stuff\2018"
MsgBox ("Select file")
ret1 = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", _
, "Please select file")
If ret1 = False Then Exit Sub
Application.ScreenUpdating = False
Set wb2 = Workbooks.Open(ret1)
On Error Resume Next
wb1.Sheets("Sheet1").Range("B6").Value = wb2.Sheets("Sheet1").Range("C1").Value
wb1.Sheets("Sheet1").Range("C6").Value = wb2.Sheets("Sheet1").Range("C2").Value
wb1.Sheets("Sheet1").Range("D6").Value = wb2.Sheets("Sheet1").Range("C3").Value
wb1.Sheets("Sheet1").Range("E6").Value = wb2.Sheets("Sheet1").Range("E3").Value
wb1.Sheets("Sheet1").Range("F6").Value = wb2.Sheets("Sheet1").Range("C27").Value
wb1.Sheets("Sheet1").Range("G6").Value = wb2.Sheets("Sheet1").Range("D27").Value
wb1.Sheets("Sheet1").Range("H6").Value = wb2.Sheets("Sheet1").Range("E28").Value
wb2.Close savechanges:=False
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

In the code above, B6:H6 represent the top row of the table, while C1, C2, C3, E3, C27, D27, & E28 contain the data I wish to extract from each file in the folder. I need it to be able to fill the table without taking more than a minute (~400 files in folder).

Is there a simple way to do this? I was able to do it using a query, but it isn't as neat and clean as I would like.

I am using Excel 2016.

Hi eljacinto,

Try:
(UNTESTED)

Come back with any questions.

ALSO NOTE: You're going to have to enable Microsoft Scripting runtime to use the .fso object.
Its easy, in the code window, click: Tools > References > 'Check the box "Microsoft Scripting Runtime"'

Code:

---

Sub Test()
Application.ScreenUpdating = False

Dim fso As New FileSystemObject ' Enables macro to search file explorer for files
Dim dataFiles As Variant ' String array that holds the file names
Dim qwp As Long ' Forloop variable
Dim WBT As Workbook
Dim WBD As Workbook
Dim WPN As Worksheet
Dim WSD As Worksheet
dataFiles = Application.GetOpenFilename("data Files(*.), *.)", 1, "Select ALL Desired Files.", "Select", True) ' Gets file names of shift/ctrl clicked files

Set WBT = ThisWorkbook
Set WPN = WBT.Sheets(1)

' Initializes counter variable
Counter = 0

' Sets counter equal to amount of dataFiles chosen
For qwp = LBound(dataFiles) To UBound(dataFiles)
    Counter = Counter + 1
Next qwp

'Execute for every sample
For m = 1 To Counter


    ' Open Workbook with m'th string name from dataFiles string array
    dataWorkbookFileName = fso.GetFileName(dataFiles(m)) ' Gets filename of file
    Workbooks.Open dataFiles(m) ' Opens dataFile Workbook
   
    Set WBD = Workbooks(dataWorkbookFileName)
    Set WSD = WBD.Sheets(1)
   
    Dim cArr(), rVal1 As Variant, rVal2 As Variant, rVal3 As Variant, rVal4 As Variant
    With WSD
        cArr = Range(.Cells(1, 3), .Cells(3, 3)).Value
        rVal1 = .[E3].Value
        rVal2 = .[C27].Value
        rVal3 = .[D27].Value
        rVal4 = .[E28].Value
    End With
    With WPN
        .Cells(m + 5, 2).Value = cArr(1, 1)
        .Cells(m + 5, 3).Value = cArr(2, 1)
        .Cells(m + 5, 4).Value = cArr(3, 1)
        .Cells(m + 5, 5).Value = rVal1
        .Cells(m + 5, 6).Value = rVal2
        .Cells(m + 5, 7).Value = rVal3
        .Cells(m + 5, 8).Value = rVal4
    End With
   
    Application.DisplayAlerts = False
    WBD.Close
    Application.DisplayAlerts = True
   
Next m
Application.ScreenUpdating = True
End Sub

---

Also, I forgot to mention. Using the above code you can shift-click or crtl-click all the files in the folder, so you can uninclude any you need to.