Excel VBA: Макрос для склеивания данных с нескольких листов (со сложными условиями)

[strekoza]

Добрый день! Необходима помощь в написании сложного макроса (может быть для гуру простого).

В примере представлена выдержка из основного файла.

В расчетный лист 1, расчетный лист 2 складываются нужные значения с различных страниц (в последующем хочу перенести в отдельные книги), поэтому то что выделено желтым является в исходном файле формулами, в моем файле с примером это просто значения.

В расчетных листах может быть неодинаковое количество значений.
В примере следующее:
В расчетном листе 1 это РЭС-1... РЭС-4.
В расчетном листе 2 это РЭС-1... РЭС-4.

А может быть любое количество от 0 до 50 (значений может совсем не быть, просто останутся поля с "0").

В основном файле будет всего 5 таких листов.


Результатом должна быть склейка друг за другом всех заполненных столбцов (не нулевых и не "Н/Д") из всех таблиц в одну на новом листе. При этом (но не обязательно) должно меняться название параметра: последовательность от 1 до последнего элемента полученного множества столбцов (параметр отмечен красным цветом на листе "ожидаемый результат").

В основном файле много других страниц. Поэтому нужно учитывать листы, содержащие слово расчетный!

Пример в приложении! Но в исходном файле будет всего 750 строк вниз (я обрезала на значении ВДН-12, дальше идут аналогичные значения).

Рассмотрю любые советы. Спасибо!

[вложение удалено администратором]

[Администратор]

А в чём сложность руками сделать эту работу?
Если все столбцы заполняются по порядку, то просто выделяете первый столбец, затем находите визуально последний столбец, выделяете эти столбцы и копируете на пустой лист. И так для всех листов. Затем остается удалить первую строку и в первую строку записать по порядку РЭС.

[strekoza]

Потому что основная таблица на данном этапе похожа на монстра с кучей кучей листов =)и это промежуточный, рутинный этап, который повторяется постоянно и он самый раздражающий=)а за этим следует еще куча всего изумительного.... вот я и хочу такой макрос, который можно привязать к кнопке и просто на нее нажимать... мечта у меня такая=)

[strekoza]

макрос  сформирует файл, который в дальнейшем будет активно использоваться в другой программе =)

[Администратор]

На расчётном листе достаточно проверять только строку 5, чтобы сделать вывод, копировать столбец или нет?
Если в строке 5 не ноль, то копировать столбец.

[strekoza]

Строка id антенны подойдет отлично!!!

[Администратор]

Столбцы заполняются последовательно: сначала второй, затем третий и т.д.?
Или может такое быть, что столбец 2 заполнен, столбец 3 пустой, столбец 4 заполнен?

[strekoza]

Последовательно, копируются данные с других страниц (для этого индекс используется, кстати).

[Администратор]

Макрос

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

[свернуть]

[strekoza]

Это просто гениально!!!! Спасибо вам огромное!!! Я очень вам благодарна. Чудо.