Hi Prometheus,

I omitted to allow for the workbook names in column A, so please replace the
code with the following version:

'==============
Sub Tester()
Dim MyPath As String
Dim FilesInPath As String
Dim MyFiles() As String
Dim SourceRcount As Long
Dim Fnum As Long
Dim mybook As Workbook
Dim basebook As Workbook
Dim sourceRange As Range
Dim sourceRange2 As Range
Dim destrange As Range
Dim destRange2 As Range
Dim rnum As Long
Dim CalcMode As Long

'Fill in the path\folder where the files are
MyPath = "C:\One" '"C:\Desktop\Data\"

'Add a slash at the end if the user forget it
If Right(MyPath, 1) < "\" Then
MyPath = MyPath & "\"
End If

'If there are no Excel files in the folder exit the sub
FilesInPath = Dir(MyPath & "*.xls")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If

On Error GoTo CleanUp

With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

Set basebook = ThisWorkbook
'clear all cells on the first sheet
basebook.Worksheets(1).Cells.Clear
rnum = 1

'Fill the array(myFiles)with the list of _
'Excel files in the folder
Fnum = 0
Do While FilesInPath < ""
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
FilesInPath = Dir()
Loop

'Loop through all files in the array(myFiles)
If Fnum 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
Set sourceRange = mybook.Worksheets(1).Range("F12:F18")
Set sourceRange2 = mybook.Worksheets(1).Range("G13:G18")
SourceRcount = sourceRange.Rows.Count
Set destrange = basebook.Worksheets(1).Range("B" & rnum)
Set destRange2 = basebook.Worksheets(1).Range("I" & rnum)
' This will add the workbook name in column D if you want
basebook.Worksheets(1).Cells(rnum, "A").Value = mybook.Name

sourceRange.Copy
destrange.PasteSpecial _
Paste:=xlAll, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=True
sourceRange2.Copy
destRange2.PasteSpecial _
Paste:=xlAll, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=True

rnum = rnum + 1
mybook.Close savechanges:=False
Next Fnum
End If

CleanUp:
With Application
.Calculation = CalcMode
.ScreenUpdating = True
End With

End Sub
'<<==============


---
Regards,
Norman