Sub New_rows()
Application.ScreenUpdating = False 'Больше не обновляем страницы после каждого действия
Application.Calculation = xlCalculationManual 'Расчёты переводим в ручной режим
Application.EnableEvents = False 'Отключаем события
Dim i%, ii%
For i = Cells(Rows.Count, 2).End(xlUp).Row To 10 Step -1
    
    If Cells(i, 2).Value <> "" And Cells(i, 2).MergeCells = False Then
        Rows(i & ":" & i).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        Rows(i + 1 & ":" & i + 1).Copy
        Rows(i & ":" & i).PasteSpecial Paste:=xlPasteFormats
        For ii = 1 To 5
            Range(Cells(i, ii), Cells(i + 1, ii)).MergeCells = True
        Next ii
        Cells(i, 6).Value = "план"
        Cells(i, 9).Value = "то"
        Cells(i + 1, 6).Value = "выполн"
    End If
Next i
Application.ScreenUpdating = True 'Включаем обновление экрана после каждого события
Application.Calculation = xlCalculationAutomatic 'Расчёты формул - снова в автоматическом режиме
Application.EnableEvents = True 'Включаем события
End Sub