Excel VBA Макросы: Автоматическое добавление и удаление строк в листы Excel, у которых имена в виде дней.

[Vitnig]

В файле есть лист "Номенклатура" и один или несколько листов, у которых имена в виде чисел от 1 до 31 (это дни месяца). Кроме того, в файле есть и другие листы.

На листе "Номенклатура" и листах-днях одинаковое расположение строк.

Нужны макросы, которые бы запускались кнопками и делали следующее. При добавлении или удалении строки на листе "Номенклатура", должна добавляться или удаляться эта же строка на всех листах-днях. При этом остальные листы должны оставаться без изменений.

Нашел в интернете макросы для добавления/удаления строк с помощью кнопок, но эти макросы работают только с одним листом-днём. Не могу переделать его под свою задачу.

Макросы

Option Explicit

Const LinkedName = "2"

Private Sub cmdAddRow_Click()
    AddRow
End Sub

Private Sub cmdDelRow_Click()
    DelRow
End Sub

Private Sub AddRow()
    If MsgBox("Добавить строку?", vbQuestion + vbOKCancel) = vbOK Then
        Dim nRow As Long
        nRow = ActiveCell.Row
        Rows(nRow).Insert
        With Sheets(LinkedName)
            .Rows(nRow).Insert
            .Range(.Cells(nRow, 1), .Cells(nRow, 4)).Formula = _
                "=INDEX('" & ActiveSheet.Name & "'!$A:$D,ROW(),COLUMN())"
        End With
    End If
End Sub

Private Sub DelRow()
    If MsgBox("Удалить строку?", vbQuestion + vbOKCancel) = vbOK Then
        Dim nRow As Long
        nRow = ActiveCell.Row
        Rows(nRow).Delete
        Sheets(LinkedName).Rows(nRow).Delete
    End If
End Sub

[свернуть]

Вместо этого кода:
            .Range(.Cells(nRow, 1), .Cells(nRow, 4)).Formula = _
                "=INDEX('" & ActiveSheet.Name & "'!$A:$D,ROW(),COLUMN())"

нужно написать код для вставки формулы, которая находится на листе-дне в столбце B:
=Номенклатура!B5


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

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

Макрос

Private Sub cmdAddRow_Click()
    AddRow
End Sub

Private Sub cmdDelRow_Click()
    DelRow
End Sub

Private Sub AddRow()

    Dim sh_act As Worksheet, sh As Worksheet
    Dim r As Long
   
   
    '1. Сообщение для защиты от случайного запуска макроса.
    If MsgBox("Добавить строку?", vbQuestion + vbYesNo) = vbNo Then Exit Sub
   
    ' Отключение монитора и формул, чтобы ускорить макрос.
    Application.ScreenUpdating = False
    Dim calc As Long: calc = Application.Calculation
   
    '2. Присваиваем имя активному листу. Может быть так будет удобнее читать и писать код.
    Set sh_act = ActiveSheet
    '3. Запись номера активной строки.
    r = ActiveCell.Row
    '4. Вставка строки на основном листе.
    sh_act.Rows(r).Insert
   
    '5. Вставка строк на листах-днях.
    For Each sh In Worksheets
        ' Если имя листа в виде числа.
        If IsNumeric(sh.Name) Then
            ' Если имя листа - это число от 1 до 31.
            If (sh.Name >= 1) And (sh.Name <= 31) Then
                sh.Rows(r).Insert
                sh.Cells(r, "B").FormulaR1C1 = "='" & sh_act.Name & "'!RC"
            End If
        End If
    Next sh
   
    ' Включения.
    Application.Calculation = calc
    Application.ScreenUpdating = True

End Sub

Private Sub DelRow()
   
    Dim sh_act As Worksheet, sh As Worksheet
    Dim r As Long
   
   
    '1. Сообщение для защиты от случайного запуска макроса.
    If MsgBox("Удалить строку?", vbQuestion + vbYesNo) = vbNo Then Exit Sub
   
    ' Отключение монитора и формул, чтобы ускорить макрос.
    Application.ScreenUpdating = False
    Dim calc As Long: calc = Application.Calculation
   
    '2. Присваиваем имя активному листу. Может быть так будет удобнее читать и писать код.
    Set sh_act = ActiveSheet
    '3. Запись номера активной строки.
    r = ActiveCell.Row
    '4. Удаление строки на основном листе.
    sh_act.Rows(r).Delete
   
    '5. Удаление строк на листах-днях.
    For Each sh In Worksheets
        ' Если имя листа в виде числа.
        If IsNumeric(sh.Name) Then
            ' Если имя листа - это число от 1 до 31.
            If (sh.Name >= 1) And (sh.Name <= 31) Then
                sh.Rows(r).Delete
            End If
        End If
    Next sh
   
    ' Включения.
    Application.Calculation = calc
    Application.ScreenUpdating = True
   
End Sub

[свернуть]

[Vitnig]

Премного благодарен!
Всё работает.