Sub ОчисткаСводнойТаблицы() 
Application.ScreenUpdating = False 
Me.Range("5:5000").ClearContents 
Me.Range("5:500").EntireRow.AutoFit 
End Sub 

Sub ЗаполениеСводнойТаблицы() 
Application.ScreenUpdating = False: Application.DisplayAlerts = False 

Dim coll As New Collection, wb As Workbook, sh As Worksheet, newRow As Range 
Mask = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, "*.xls") 

Filename = Dir(Mask) 
While Filename <> "" 
If Not Filename Like ThisWorkbook.Name & "*" Then coll.Add Filename 
Filename = Dir 
Wend 

'For Each Item In coll: Debug.Print Item: Next 
On Error Resume Next 
For Each Item In coll 
Set wb = Workbooks.Open(Replace(ThisWorkbook.FullName, ThisWorkbook.Name, Item), , True) 
If Not wb Is Nothing Then 
Set sh = wb.Worksheets(1) 
LastRow = sh.Range("a65000").End(xlUp).Row 
If LastRow > 4 Then 
For i = 5 To LastRow 
Set newRow = Me.Range("a65000").End(xlUp).Offset(1) 
sh.Rows(i).Copy newRow 
newRow.EntireRow.AutoFit 
Next i 
End If 
wb.Close False 
End If 
Next 
Application.DisplayAlerts = True 
End Sub