Форум по VBA и MS Office

Private Sub CommandButton1_Click()
Workbooks.Open Filename:="D:\1.xlsx"
Workbooks("1.xlsx").Worksheets("Лист1").Range("A16:E16").Copy
Workbooks("Свод.xlsm").Activate
ActiveWorkbook.Worksheets("Лист1").Range("A1").Select
ActiveSheet.Paste
Workbooks("1.xlsx").Close
End Sub

Sub Макрос()
   
    Dim sh_src As Worksheet, sh_res As Worksheet
    Dim FNs As Collection
    Dim lr As Long, i As Long


    ' Отключение монитора, чтобы ускорить макрос.
        ' Если много формул, можно ещё отключить формулы.
    Application.ScreenUpdating = False

    '1. Присваиваем имя листу, в который нужно вставить данные.
        ' Далее в коде будем обращаться к этому листу по этому имени.
    Set sh_res = ActiveSheet
   
    '2. Запись в коллекцию "FNs" полных имён файлов, из которых нужно извлечь данные.
    ПолучитьПолныеИменаФайлов FNs

    '3. Извлечение данных из файлов на активный лист.
    For i = 1 To FNs.Count
   
        '1) Открытие файла и назначение листу имени "sh_src".
            ' Далее в коде будем обращаться к листу по этому имени.
        Set sh_src = Workbooks.Open(Filename:=FNs(i), ReadOnly:=True).Worksheets("Лист1")
       
        '2) Копирование фрагмента на листе-источнике.
        sh_src.Range("A16:E16").Copy
       
        '3) Поиск последней строки на листе-результате по столбцу A.
            ' End не ищет в скрытых строках.
        lr = sh_res.Cells(sh_res.Rows.Count, "A").End(xlUp).Row + 1
       
        '4) Вставка данных на лист-результат.
        sh_res.Cells(lr, "A").PasteSpecial xlPasteAll
       
        '5) Закрытие файла-источника.
        sh_src.Parent.Close SaveChanges:=False
       
    Next i
   
    ' Включение монитора.
    Application.ScreenUpdating = True
   
    '4. Сообщение.
    MsgBox "Готово.", vbInformation
   
End Sub

Private Sub ПолучитьПолныеИменаФайлов(FNs As Collection)

    Dim fso As Scripting.FileSystemObject
    Dim папка As Scripting.Folder, файл As Scripting.File
   
   
    '1. Создание объекта, который умеет работать с папками и файлами.
    Set fso = New FileSystemObject
   
    '2. Присваиваем имя папке, с которой надо работать.
    ' Здесь укажите полное имя папки. На конце слеш не нужно указывать.
    Set папка = fso.GetFolder("C:\Users\User\Desktop\Эксель-файлы")
   
    '3. Создание коллекции.
    Set FNs = New Collection
   
    '4. Запись в коллекцию полных имён файлов, которые находятся в указанной папке.
        ' Если эксель-файл открыт, то в папке будет скрытый файл, относящийся к этому файлу.
        ' Поэтому делается проверка, что файл не скрытый.
    For Each файл In папка.Files
        If (файл.Attributes And Hidden) = 0 Then
            If файл.Name Like "*.xlsx" Then
                FNs.Add Item:=файл.Path
            End If
        End If
    Next файл
   
End Sub