Sub Продлить()
    
    Dim sh As Worksheet
    Dim lr1 As Long, lr2 As Long, i As Long
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    lr1 = Columns("A").Find(What:="*", LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False _
        , SearchFormat:=False).Row
    
    For i = 2 To Worksheets.Count
        Set sh = Worksheets(i)
        lr2 = sh.Columns("A").Find(What:="*", LookIn:=xlFormulas, LookAt:= _
                xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False _
                , SearchFormat:=False).Row
        If lr2 < 3 Then
            MsgBox "На листе " & sh.Name & " вставьте сначала вручную строку 3!", vbExclamation
        ElseIf lr2 > lr1 Then
            sh.Rows(lr1 + 1 & ":" & lr2).Delete
        ElseIf lr2 < lr1 Then
            sh.Rows(3).Copy sh.Rows(lr2 + 1 & ":" & lr1)
        End If
    Next

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    MsgBox "Готово!", vbInformation

End Sub