Boucle macro en insérant lignes

Sub ABCDEF()
    Dim tbl, a, dico As Dictionary, i As Long, L As Long
    
    Application.ScreenUpdating = False
    
    With Sheet1
        tbl = .UsedRange

        Set dico = New Dictionary
        'microsoft scripting runtime doit être coché dans menu outils,choix références
        '  ou cette ligne si problème et déclarer dico as Object à la place de as dictionary(ligne dim)
        'Set mondico = CreateObject("scripting.dictionary")
        For i = 2 To UBound(tbl, 1)
            dico(tbl(i, 1)) = tbl(i, 1)
        Next i

        a = dico.items
        L = .Range("A65536").End(xlUp).Row

        For i = UBound(a) To 0 Step -1
            If i > 0 Then
                nbl = Application.CountIf(.Range("A:A"), "=" & a(i))
                L = L - nbl
                b = .Cells(L + 1, 2)
                For c = 1 To 3
                    .Rows(L + c).Insert
                Next c
                .Cells(L + 1, 1) = a(i): .Cells(L + 1, 2) = b: .Cells(L + 1, 3) = 2000
                .Cells(L + 2, 1) = a(i): .Cells(L + 2, 2) = b: .Cells(L + 2, 3) = 2001
                .Cells(L + 3, 1) = a(i): .Cells(L + 3, 2) = b: .Cells(L + 3, 3) = 2002
            End If
        Next i
    End With
    
    Application.ScreenUpdating = True
    
End Sub

Sub insérer()
Application.ScreenUpdating = False
With Sheets("Sheet1")
For lig = .Cells(Rows.Count, 3).End(xlUp).Row To 2 Step -1
    If .Cells(lig, 3) = 2003 Then
        .Rows(lig).Copy
        .Rows(lig).Resize(3, 1).Insert
        .Cells(lig, 3).Resize(3, 1) = Application.Transpose(Array(2000, 2001, 2002))
        .Cells(lig, 4).Resize(3, 1) = ""
    End If
Next lig
End With
Application.ScreenUpdating = True
Application.CutCopyMode = False
End Sub

Sub essai()
Dim i As Long, x as long
    Application.ScreenUpdating = False
    For i = Range("C" & Rows.Count).End(xlUp).Row To 3 Step -1
        If Cells(i - 1, "C") > Cells(i, "C") Then
            x = Cells(i, "C") - 2000
            Rows(i).Resize(x).Insert
            With Cells(i, "C")
                .Value = 2000
                .AutoFill .Resize(x), 2
            End With
        End If
    Next
    Application.ScreenUpdating = True
End Sub

Sub essai()
Dim i As Long, x As Long
    Application.ScreenUpdating = False
    For i = Range("C" & Rows.Count).End(xlUp).Row To 3 Step -1
        If Cells(i - 1, "C") > Cells(i, "C") Then
            x = Cells(i, "C") - 2000
            Rows(i).Resize(x).Insert
            With Cells(i, "C")
                .Value = 2000
                .AutoFill .Resize(x), 2
                With .Offset(, -2).Resize(x, 2)
                    .Value = Cells(i - 1, "A").End(xlDown).Resize(, 2).Value
                End With
            End With
        End If
    Next
    Application.ScreenUpdating = True
End Sub

Sub Traitement()
Application.ScreenUpdating = False
mDEBUT
mMILIEU
mFIN
Application.ScreenUpdating = True
End Sub
Private Sub mDEBUT()
Dim i&
For i = Cells(Rows.Count, 1).End(3).Row To 2 Step -1
If Cells(i, 3) = "2003" Then
Rows(i).Resize(5).Insert Shift:=xlDown
End If
Next
End Sub
Private Sub mMILIEU()
Dim dl&
dl = Cells(Rows.Count, 1).End(3).Row + 5
With Range(Cells(7, 1), Cells(dl, 2))
.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
.Value = .Value
End With
End Sub
Private Sub mFIN()
Range("D7:D9").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("C7:C8") = Application.Transpose(Array(2000, 2001))
Range("C7:C8").AutoFill Destination:=Range("C7:C22"), Type:=xlFillDefault
Range("C7:C22").AutoFill Destination:=Range("C7:C4822"), Type:=xlFillCopy
Rows("2:6").Delete
Range("A4812:B4817").FillDown
End Sub

Sub Version1()
Dim a, b(), i As Long, txt As String
Dim e, n As Long, Fin As Long
    Fin = Application.InputBox("Choisir l'année", , 2015, Type:=1)
    Fin = Fin - 1999
    Application.ScreenUpdating = False
    With Sheets("Sheet1").Range("A1").CurrentRegion
        a = .Value
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
            For i = 2 To UBound(a, 1)
                .Item(a(i, 1)) = a(i, 2)
            Next
            ReDim b(1 To .Count * Fin, 1 To UBound(a, 2))
            For Each e In .keys
                For i = 1 To Fin
                    n = n + 1
                    .Item(e & i + 1999) = n
                    b(n, 1) = e: b(n, 2) = .Item(e): b(n, 3) = i + 1999
                Next
            Next
            For i = 2 To UBound(a, 1)
                txt = a(i, 1) & a(i, 3)
                If .exists(txt) Then
                    b(.Item(txt), 2) = a(i, 2)
                    b(.Item(txt), 4) = a(i, 4)
                End If
            Next
        End With
        With .Offset(, .Columns.Count + 1)
            .CurrentRegion.Clear
            .Resize(, UBound(a, 2)).Value = a
            .Offset(1).Resize(n, UBound(b, 2)).Value = b
            With .CurrentRegion
                With .Rows(1)
                    .Font.Bold = True
                    .Interior.ColorIndex = 40
                    .BorderAround Weight:=xlThin
                End With
                .Font.Name = "calibri"
                .VerticalAlignment = xlCenter
                .HorizontalAlignment = xlCenter
                .Borders(xlInsideVertical).Weight = xlThin
                .BorderAround Weight:=xlThin
                .Columns.AutoFit
            End With
        End With
    End With
    Application.ScreenUpdating = True
End Sub

Sub Version2()
Dim a, b(), i As Long, txt As String
Dim e, n As Long, Fin As Long
    Fin = Application.InputBox("Choisir l'année.", , 2015, Type:=1)
    Fin = Fin - 1999
    Application.ScreenUpdating = False
    With Sheets("Sheet1").Range("A1").CurrentRegion
        a = .Value
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
            For i = 2 To UBound(a, 1)
                .Item(a(i, 1)) = a(i, 2)
            Next
            ReDim b(1 To .Count * Fin, 1 To UBound(a, 2) + 1)
            For Each e In .keys
                For i = 1 To Fin
                    n = n + 1
                    .Item(e & i + 1999) = n
                    b(n, 1) = e: b(n, 2) = .Item(e): b(n, 3) = i + 1999
                Next
            Next
            For i = 2 To UBound(a, 1)
                txt = a(i, 1) & a(i, 3)
                If .exists(txt) Then
                    b(.Item(txt), 2) = a(i, 2)
                    b(.Item(txt), 4) = a(i, 4)
                    b(.Item(txt), 5) = "x"
                End If
            Next
        End With
        With .Offset(, .Columns.Count + 1)
            .CurrentRegion.Clear
            .Resize(, UBound(a, 2)).Value = a
            .Offset(1).Resize(n, UBound(b, 2)).Value = b
            With .CurrentRegion
                With .Rows(1)
                    .Cells(5).Value = "Existant"
                    .Font.Bold = True
                    .Interior.ColorIndex = 45
                    .BorderAround Weight:=xlThin
                End With
                .Font.Name = "calibri"
                .VerticalAlignment = xlCenter
                .HorizontalAlignment = xlCenter
                .Borders(xlInsideVertical).Weight = xlThin
                .BorderAround Weight:=xlThin
                .Columns.AutoFit
            End With
        End With
    End With
    Application.ScreenUpdating = True
End Sub

 With .Offset(, .Columns.Count + 1)
            .CurrentRegion.Clear
            .Resize(, UBound(a, 2)).Value = a
            .Offset(1).Resize(n, UBound(b, 2)).Value = b