Свод нескольких файлов Excel в один

[Стасон]

Здравствуйте, Глубокоуважаемые покорители мозга железных машин!
Помогите пользователю в решении такой незадачи. Меня зовут Стас, у меня следующая ситуация:

Первого числа каждого месяца разные люди присылают отчётные таблицы (пример файлы Excel под названием 1, 2, 3 – это три разных человека).

Мне необходимо просто сделать сводную таблицу Excel (пример файл Excel под названием Сводная таблица - это, что должно получиться).

На сегодняшний день тупо открываю файл 1, выделяю, копирую, вставляю в файл Сводная таблица. Открываю файл 2, выделяю, копирую, вставляю в файл Сводная таблица и т.д.

Уверен, что это можно автоматизировать, но в Excel я только на уровне пользователя. Если не сложно подскажите как это сделать. Заранее благодарен.

[EducatedFool]

Здравствуйте, Глубокоуважаемые покорители мозга железных машин!

Громко сказано
Мы всего лишь скромные повелители Excel

подскажите как это сделать

1) Извлекаете все файлы из вложения в одну папку
2) Открываете только один файл - Сводная таблица.xls
3) Нажимаете на красную кнопоку (необязательно)
4) Нажимаете на зелёную кнопочку

Макрос переберёт все файлы Excel (с расширением xls) в той же папке, где расположен файл Сводная таблица.xls, и скопирует все заполненные строки с первых листов этих файлов (листы с названием База) в текущий файл.

Вот весь код:

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

    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

[Стасон]

Спасибо за помощь.
Опробывал, всё классно работает.
Не знаю как и благодарить.

Хотел пивком угостить, вот только не знаю куда в системном блоке его заливать

А если серьезно, то я юрист в области исполнительного производства (алименты, принудительное взыскание долгов и всё в таком роде). Если будут трудности, готов ответить взаимной помощью.