Добавление новой строки с формулами на всех листах

Question

У меня есть книга Excel с 11 листами. В настоящее время у меня есть функция добавления новой строки, но мне нужна новая строка для сохранения формулы предыдущего / следующего, как мне это сделать?

• В настоящее время сделано с SelectionChanged как конкретная ячейка
• Я должен добавить строку, в которой текущая выбранная ячейка / строка / была

Текущий код для добавления строк, не включая формулы вообще:

Sub InsertRow(ByVal selection)

    Dim cs As String
    cs = ActiveSheet.Name
    Dim y As Integer
    y = selection
    If MsgBox("Add Row " & y & " in all Sheets?", _
    vbYesNo, "Add Row") = vbNo Then Exit Sub
    Application.ScreenUpdating = False
    Dim r As Range
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.Worksheets
        ws.Activate
        Set r = ActiveSheet.Range("A" & y)
        If y < 7 Then GoTo circumv 'Not to insert in Headers
        Range("A" & y).EntireRow.Insert

circumv:
    Next ws
    Sheets(cs).Activate
    Application.ScreenUpdating = True

End Sub

Answer 1

Вы должны добавить этот код непосредственно в каждую рабочую таблицу, где вы хотите, чтобы реакция на двойной щелчок!

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    'MsgBox ("Click")
    Call InsertMyRow
End Sub

дважды щелкните по листу, чтобы ввести там код:

Answer 2

Я запустил макрос прямо в редакторе VBA.Вы можете начать его, например, с двойного щелчка.Смотрите 2-й ответ!

Public Sub InsertMyRow() '(ByVal MyRange As Range)

    Dim cs As String
    Dim actCell As Range
    cs = ActiveSheet.Name
    Dim y As Integer
    y = ActiveCell.Row
    If MsgBox("Add Row " & y & " in all Sheets?", _
    vbYesNo, "Add Row") = vbNo Then Exit Sub
    Application.ScreenUpdating = False
    Dim r As Range
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.Worksheets
        ws.Activate
        Set actCell = ActiveCell
        Set r = ActiveSheet.Range("A" & y)
        If y < 7 Then GoTo circumv 'Not to insert in Headers
        Range("A" & y).EntireRow.Insert
        Range("A" & y - 1).EntireRow.Copy
        Range("A" & y).PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False

        If Not (IsEmpty(Range("A" & y + 1))) Then
            Range("A" & y - 1).EntireRow.Copy
            Range("A" & y + 1).PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
                SkipBlanks:=False, Transpose:=False
            Application.CutCopyMode = False
        End If
        actCell.Select

circumv:
    Next ws
    Sheets(cs).Activate
    Application.ScreenUpdating = True

End Sub