Макрос для запуска процедуры на нескольких листах Excel

Question

Я застрял с этой проблемой. Мне нужно запустить макрос, который будет делать следующее:

1. Найдите последнюю строку в таблице на листе под названием "Базовая линия".
2. Добавить строку в эту таблицу
3. Скопируйте форматы и формулы (но не значения) из строки выше в новую строку.
4. Повторите процесс для других рабочих листов (называемых "Квартал 1", "Квартал 2" и т. Д.), Имеющих ту же структуру, что и рабочая таблица "Базовая линия".

Моя проблема в том, что процесс, кажется, работает только на первом листе, Baseline, но не на других листах. Интересно, проблема в том, как я пытался заставить код копировать только формулы и форматы?

Вот код, только для таблиц базового уровня и квартала 1:

Public Sub AddRow()

On Error GoTo errhandler

    Worksheets("Baseline").Activate


'Find Last Row in Service User Details

    Dim rgeLastRowBaseline As Range
    Set rgeLastRowBaseline = ActiveWorkbook.Worksheets("Baseline").Cells.Find("Cost")


' Select and Copy Last Row

    rgeLastRowBaseline.End(xlDown).EntireRow.Select

    Selection.Offset(1).EntireRow.Insert

    rgeLastRowBaseline.End(xlDown).EntireRow.Select

    Selection.Copy

    rgeLastRowBaseline.End(xlDown).Offset(1).EntireRow.Select

    rgeLastRowBaseline.End(xlDown).Offset(1).EntireRow.PasteSpecial

    Application.CutCopyMode = False
    Selection.SpecialCells(xlCellTypeConstants, 23).Select
    Selection.ClearContents

'Quarter 1


    Worksheets("Quarter 1").Activate


    Dim rgeLastRowQ1 As Range
    Set rgeLastRowQ1 = ActiveWorkbook.Worksheets("Quarter 1").Cells.Find("Cost")

' Select and Copy Last Row

    rgeLastRowQ1.End(xlDown).EntireRow.Select


    Selection.Offset(1).EntireRow.Insert

    rgeLastRowQ1.End(xlDown).EntireRow.Select

    Selection.Copy

    rgeLastRowQ1.End(xlDown).Offset(1).EntireRow.Select

    rgeLastRowQ1.End(xlDown).Offset(1).EntireRow.PasteSpecial

    Application.CutCopyMode = False
    Selection.SpecialCells(xlCellTypeConstants, 23).Select
    Selection.ClearContents


Exit Sub


errhandler:

    Application.CutCopyMode = False
End Sub

У кого-нибудь есть предложения, пожалуйста?

Спасибо

Answer 1

Вам нужно будет использовать Worksheet Переменные типа. Я не исправил ваши технические решения, хотя я не полностью согласен с выбором всего.

Sub onesheet(ws As Worksheet)
On Error GoTo errhandler
ws.Activate

Dim rgeLastRowQ1 As Range
Set rgeLastRowQ1 = ws.Cells.Find("Cost")
' Select and Copy Last Row

rgeLastRowQ1.End(xlDown).EntireRow.Select

Selection.Offset(1).EntireRow.Insert

rgeLastRowQ1.End(xlDown).EntireRow.Select

Selection.Copy

rgeLastRowQ1.End(xlDown).Offset(1).EntireRow.Select

rgeLastRowQ1.End(xlDown).Offset(1).EntireRow.PasteSpecial

Application.CutCopyMode = False
Selection.SpecialCells(xlCellTypeConstants, 23).Select
Selection.ClearContents
Exit Sub

errhandler:

Application.CutCopyMode = False
End Sub

Sub sheetloop()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
    If ws.Name = "Baseline" Or ws.Name Like "Quarter*" Then Call onesheet(ws)
Next ws
End Sub