Форум по VBA и MS Office

Sub Макрос()

    Dim sh_свод As Worksheet, sh_src As Worksheet
    Dim r_свод As Long, i As Long
   
   
    ' Отключение монитора и формул, чтобы ускорить макрос.
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
   
    '1. Присваиваем листу "СВОД" имя "sh_свод".
        ' Далее в коде будем обращаться к листу по этому имени.
    Set sh_свод = Worksheets("СВОД")
   
    '2. Копирование данных из всех листов, кроме последнего, на лист "СВОД".
    For i = 2 To Worksheets.Count - 1
       
        '1) Присваиваем листу, из которого надо скопировать данные, имя "sh_src".
        Set sh_src = Worksheets(i)
       
        '2) Переходим на лист, чтобы после работы макроса не был выделен копируемый фрагмент
            ' для удобства юзера.
        sh_src.Activate
       
        '3) Сбрасываем автофильтр, чтобы не было скрытых строк (на всякий случай).
        If sh_src.AutoFilterMode = True Then
            sh_src.AutoFilter.ShowAllData
        End If
       
        '4) Установка курсора "r_свод" под последней заполненной строкой на листе "СВОД".
            ' Ошибка будет, если лист "СВОД" пустой.
        On Error Resume Next
        r_свод = sh_свод.Cells.Find(What:="*", LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _
            SearchDirection:=xlPrevious, MatchCase:=False, SearchFormat:=False).Row
        On Error GoTo 0
        r_свод = r_свод + 1
       
        '5) Копирование данных из листа-источника на лист "СВОД".
        sh_src.Range("A1:K19").Copy
        sh_свод.Cells(r_свод, "A").PasteSpecial xlPasteFormats
        sh_свод.Cells(r_свод, "A").PasteSpecial xlPasteValuesAndNumberFormats
       
    Next i
    Application.CutCopyMode = False
   
    '3. Сбрасываем выделение после копирования.
    Application.Goto sh_свод.Range("A1"), True
   
    '4. Включение и сообщение.
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    MsgBox "Готово.", vbInformation

End Sub