inserer nbr ligne excel egale nbr de ligne au dessus

Sub insert_row()
Dim i, j, k As Integer
i = 1
k = 0
While Sheets(1).Cells(i, 1) <> ""
    k = k + 1
    If Sheets(1).Cells(i, 2) <> Sheets(1).Cells(i + 1, 2) Then
        If (k > 1) And (i > 2) Then k = k + 1
        j = 0
        While j < k
          Sheets(1).Cells(i + 1, 2).EntireRow.Insert Shift:=xlDown
          j = j + 1
          i = i + 1
        Wend
        k = 0
    End If
    i = i + 1
Wend
End Sub

  Option Explicit
Sub AnyMoreBlankLines()
Dim cel As Range, blanc%, aOld%, aNew%, i&, NbLigne%
Dim F2 As Worksheet

Application.ScreenUpdating = False
Set F2 = Sheets(2)
blanc = Year(0)

With F2   ' La colonne "DATE" commence ligne 1
  aOld = Year(.Range("B1"))
  For Each cel In .Range("B2:" & .Range("B65000").End(xlUp).Address)
    aNew = Year(cel)    ' le décalage ne jouera que sur l'année
    Select Case aNew
      Case blanc    ' cellule vide
    
      Case aOld
        NbLigne = NbLigne + 1
      
      Case Else       ' insérer "NbLigne" lignes et au moins 1 ligne
        If NbLigne = 0 Then NbLigne = 1
        For i = 1 To NbLigne: cel.EntireRow.Insert Shift:=xlDown: Next i    '
        aOld = aNew
        NbLigne = 0
    End Select
  Next cel
End With
Application.ScreenUpdating = True

End Sub

Option Explicit

Sub Pre_Processing()
Dim tbl, nbCol&, nbLig&, F3 As Worksheet

Application.ScreenUpdating = False
Set F3 = Worksheets("Feuil3")
With F3

   ' sélection de la zone renseignée
  Set tbl = .Range("A1").CurrentRegion
  
   ' ajout d'une colonne de "1" caractérisant les données originales
  tbl.Offset(1, tbl.Columns.Count).Resize(tbl.Rows.Count - 1, 1) = 1
  
   'reproduit ce même tableau à la suite des données originales
  tbl.Offset(1, 0).Resize(tbl.Rows.Count - 1, tbl.Columns.Count).Copy _
                Destination:=.Range("A1").End(xlDown).Offset(1, 0)
                
   'réordonne les données originales et dupliquées
   '   l'absence ou la présence du "1" en dernière colonne distingue
   '           de façon permanente les données originales de leur copie
  Set tbl = .Range("A1").CurrentRegion
  nbCol = tbl.Columns.Count
  nbLig = tbl.Rows.Count
   ' tri selon la date puis selon
  tbl.Offset(1, 0).Resize(tbl.Rows.Count - 1).Sort key1:=.Range("E2:E" & nbLig), order1:=xlAscending, _
              key2:=.Range(Cells(2, nbCol), Cells(nbLig, nbCol)), order2:=xlDescending, Header:=xlNo

End With
Application.ScreenUpdating = True

End Sub