Sub CollectInfo()
Dim BazaWb As Workbook 'книга с макросом (общий файл)
Dim BazaSht As Worksheet 'лист в общем файле куда будем копировать
Dim iTempFileName As String 'имя поочерёдно открываемого файла
Dim iPath As String 'путь к папке, где лежат все файлы
Dim iLastRowBaza As Long 'последняя заполненная строка в общем файле
Dim iLastRowTempWb As Long 'последняя заполненная строка в по-очерёдно открываемом файле
Dim iNumFiles As Long 'количество открываемых файлов
Dim TempSht As Worksheet 'каждый лист в открываемых файлах

    If MsgBox("Скопировать информацию из всех файлов в текущей папке в данный файл?", vbOKCancel + vbQuestion, _
        "Копирование инфо") = vbCancel Then Exit Sub
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .Calculation = xlManual
        .ShowWindowsInTaskbar = False
        Set BazaWb = ThisWorkbook
        iPath = BazaWb.Path & "\"
        iTempFileName = Dir(iPath & "*.xls")
        Do While iTempFileName <> ""
            If iTempFileName <> BazaWb.Name Then
                Set BazaSht = BazaWb.Sheets.Add
                On Error Resume Next
                BazaWb.Sheets(Left(iTempFileName, Len(iTempFileName) -  4 )).Delete
                On Error GoTo  0 
                BazaSht.Name = Left(iTempFileName, Len(iTempFileName) -  4 )
                With .Workbooks.Open _
                     (Filename:=iPath & iTempFileName, UpdateLinks:=False, ReadOnly:=True)
                    iNumFiles = iNumFiles +  1 
                    For Each TempSht In .Worksheets
                        iLastRowBaza = BazaSht.Cells(Rows.Count,  1 ).End(xlUp).Row +  3 
                        With TempSht
                            iLastRowTempWb = .Cells(Rows.Count,  1 ).End(xlUp).Row
                            'копируем диапазон со столбца А до АС включительно
                            .Range(.Cells( 1 ,  1 ), .Cells(iLastRowTempWb, "AC")).Copy Destination:=BazaSht.Cells(iLastRowBaza,  1 )
                        End With
                    Next
                    .Close saveChanges:=False
                    BazaSht.Rows("1:3").Delete
                End With
            End If
            iTempFileName = Dir
        Loop
        .Calculation = xlAutomatic
        .ShowWindowsInTaskbar = True
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    MsgBox "Информация скопирована из " & iNumFiles & " файлов!", vbInformation, "Конец"
End Sub