Sub CopyData()
Application.ScreenUpdating = False
Dim desWS As Worksheet, srcWB As Workbook, ws As Worksheet
Set desWS = ThisWorkbook.Sheets("Summary")
Dim FolderName As String
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
FolderName = .SelectedItems(1) & "\"
End With
ChDir FolderName
strExtension = Dir("*.xlsx")
Do While strExtension <> ""
Set srcWB = Workbooks.Open(FolderName & strExtension)
For Each ws In Sheets
With ws
desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1, 0) = .Range("A1")
desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1, 0) = .Range("A3")
desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1, 0) = .Range("B2")
desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1, 0) = .Range("B4")
End With
Next ws
srcWB.Close False
strExtension = Dir
Loop
Application.ScreenUpdating = True
End Sub