Extracting the same cells from all Excel files in a folder

[schillaci]

I'm looking to extract the same cells from about 500 excel files that are contained in the same folder. Essentially I'm looking to pull out cell A5 which is the company name and cell A2 which is the date of the latest data in the file.
The final result should be like this with one line for each file in the folder;

Company name (cellA5)	date of last data (CellA2)
company ABC	31/12/2022
Widget co	30/9/2022
company XYZ	30/9/2022
alpha company	31/12/2022
delta co	30/11/2022
123 ltd	31/12/2022

 

[DanteAmor]

Run the macro, select the folder where the files are. The macro will take cells A5 and A2 from the files that are in the folder but always from the first sheet of each book.

The results will be on the first sheet of your book with the macro. If you want them in another sheet, change in this line With Sheets(1) (1) by the name of your sheet in quotes, for example With Sheets("Summary")

Sub extract_same_cells()
  Dim sPath As String, sFile As String
  Dim i As Long
 
  With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Select Folder"
    If .Show <> -1 Then Exit Sub
    sPath = .SelectedItems(1) & "\"
  End With
 
  sFile = Dir(sPath & "*.xls*")
  i = 2
  With Sheets(1)
    .Rows("2:" & Rows.Count).ClearContents
    Do While sFile <> ""
      .Range("A" & i).Value = GetObject(sPath & sFile).Sheets(1).Range("A5").Value
      .Range("B" & i).Value = GetObject(sPath & sFile).Sheets(1).Range("A2").Value
      i = i + 1
      sFile = Dir()
    Loop
  End With
End Sub

 

[schillaci]

Thank you so much.
That seems to work. Very impressive