Форум по VBA и MS Office

Sub макрос()

    Dim sh_res As Worksheet, cols_src As Range
    Dim sh_src As Worksheet, lc_src As Long, lc_res As Long, c As Long
   
   
    ' Отключение монитора, чтобы ускорить макрос.
    Application.ScreenUpdating = False
   
    '1. Создание листа-результата.
    Set sh_res = Worksheets.Add(After:=Worksheets(Worksheets.Count))
   
    '2. Копирование столбцов из расчётных листов на лист-результат.
    For Each sh_src In Worksheets
   
        '1) Если имя листа не начинается словом "расчет", то переход к следующему листу.
        If Not sh_src.Name Like "расчет*" Then
            GoTo metka_NextSheet
        End If
       
        '2) Поиск последнего столбца с данными. Для этого просматривается строка 5.
            ' Если в строке 5 не ноль, значит этот столбец надо скопировать.
        For lc_src = 2 To sh_src.Columns.Count
            If sh_src.Cells(5, lc_src).Value = 0 Then
                Exit For
            End If
        Next lc_src
        lc_src = lc_src - 1
        ' Если все столбцы пустые.
        If lc_src = 1 Then
            GoTo metka_NextSheet
        End If
       
        '3) Присваиваем имя "cols_src" копируемому фрагменту.
        ' Если это первое копирование, то нужно скопировать первый столбец из листа-источника.
            ' Это столбец-заголовок.
        If sh_res.Range("A1").Value = "" Then
            Set cols_src = sh_src.Columns(1).Resize(, lc_src)
        Else
            Set cols_src = sh_src.Columns(2).Resize(, lc_src - 1)
        End If
       
        '4) Поиск последнего столбца на листе-результате.
        ' Если это первое копирование.
        If sh_res.Range("A1").Value = "" Then
            lc_res = 1
        Else
            lc_res = sh_res.usedrange.Columns.Count + 1
        End If
       
        '5) Копирование.
        ' Копирование фрагмента-источника.
        cols_src.Copy
        ' Вставка только данных (без формул и оформления).
        sh_res.Cells(1, lc_res).PasteSpecial xlPasteValues
        ' Вставка оформления.
        sh_res.Cells(1, lc_res).PasteSpecial xlPasteFormats
        ' Вставка ширин столбцов.
        sh_res.Cells(1, lc_res).PasteSpecial xlPasteColumnWidths
       
metka_NextSheet:
    Next sh_src
   
    ' Выход из режима копирования.
    Application.CutCopyMode = False
   
    '3. Удаление на листе-результате первой строки.
    sh_res.Rows(1).Delete
   
    '4. Нумерация РЭС-1.
    lc_res = sh_res.usedrange.Columns.Count
    For c = 2 To lc_res
        sh_res.Cells(1, c).Value = "РЭС-" & c - 1
    Next c
   
    '5. Убирание выделения после копирования.
    sh_res.Range("A1").Select
   
    ' Вкл. монитора.
    Application.ScreenUpdating = True
   
End Sub