How do I inserts a calculated number of blank rows when data changes?

Floatyman 

Here is the code...is in German vba commands.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim zeilenanzahl As Long
Dim x As Integer
Dim i As Integer
x = 1
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
If Target.Column = 1 And Target.Row > 2 Then
Worksheets("2021").Unprotect Password:="Floatyman"
On Error GoTo Notausgang
zeilenanzahl = InputBox("How many rows?", "Insert rows")
With ActiveCell
For i = 1 To zeilenanzahl
If ActiveCell = "" Then
.EntireRow.Copy
.EntireRow.Offset(x, 0).Insert shift:=xlDown
.EntireRow.Offset(x, 0).PasteSpecial
ActiveCell = 1
.EntireRow.Offset(x, 0).SpecialCells(xlCellTypeConstants).ClearContents
Else
.EntireRow.Copy
.EntireRow.Offset(x, 0).Insert shift:=xlDown
.EntireRow.Offset(x, 0).PasteSpecial
.EntireRow.Offset(x, 0).SpecialCells(xlCellTypeConstants).ClearContents
ActiveCell.Offset(-x, 0).Select
End If
x = x + 1
Next i
.Offset(1, 0).Select
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Sheets("2021").Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, _
AllowFormattingCells:=True, AllowFormattingRows:=True, AllowFormattingColumns:=True, _
AllowInsertingColumns:=True, AllowSorting:=True, AllowFiltering:=True, _
Password:="Floatyman"
Notausgang:
Cancel = True
Application.CutCopyMode = False
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Sheets("2021").Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, _
AllowFormattingCells:=True, AllowFormattingRows:=True, AllowFormattingColumns:=True, _
AllowInsertingColumns:=True, AllowSorting:=True, AllowFiltering:=True, _
Password:="Floatyman"
End If
End Sub

* Kindly Mark and Vote this reply if it helps please, as it will be beneficial to more Community members reading here.

Nikolino

I know I don't know anything (Socrates)