Sub collate()
Dim F As String, c As String
Dim d As Integer, e As Integer, a As Integer, b As Integer, x As Integer
Cells(3, 1).Select
F = Dir("D:\My Documents\" & "*.xls")
Do While Len(F) > 0
ActiveCell.Formula = F
ActiveCell.Offset(1, 0).Select 'By row
F = Dir()
Loop
d = 1
x = Cells(Rows.Count, 1).End(xlUp).Row
For e = 3 To x
c = Cells(e, 1)
cells(1,2) = c
d = d + 1
Cells(d, 2) = Cells(e, 1)
For a = 2 To 100 ' enter max no of rows instead of 100
Cells(1, 1) = "='D:\My Documents\[" & c & "]sheet1'!A" & a
If Cells(1, 1) = "" Or Cells(1, 1) = 0 Then
Exit For
Else
For b = 1 To 14
Cells(1, 1) = "='D:\My Documents\[" & c & "]sheet1'!" & Chr(b + 64) & a
Cells(d, b + 3) = Cells(1, 1)
Next b
d = d + 1
End If
Next a
d = d + 1
Next e
End Sub