Sub Собрать из файлов()
Dim t As String

For i = 1 To 7

t = i
If GetWorksheetByName(t) = "" Then
Sheets.Add.Name = i
Else
Sheets(t).Select
Cells.Delete Shift:=xlUp
shCopy t
End If
Next

End Sub

Function shCopy(sh As String) ' открыть нужный файл и копирвать и закрыть его
On Error Resume Next
ChDir ThisWorkbook.Path
Workbooks.Open Filename:=ThisWorkbook.Path & "\" & sh & ".xls"
If Err Then GoTo metka1
Cells.Select
Selection.Copy
Windows(ThisWorkbook.Name).Activate
Sheets(sh).Select
ActiveSheet.Paste
Windows(sh & ".xls").Close False
Range("A1").Select
metka1:
Err.Clear
End Function

Function GetWorksheetByName(ByRef shName As String) As String 'проверка наличия листа
Dim sht As Worksheet
For Each sht In ThisWorkbook.Worksheets
If shName = sht.Name Then
GetWorksheetByName = sht.Name
Exit For
Else
GetWorksheetByName = ""
End If
Next sht
End Function