Excel rajout de date

Sub completerDates()
    ' raccourci clavier: ctrl+d
    '
    ' la macro traite la feuille active
    ' la feuille sera triée par date
    ' pour chaque date manquante 1 ligne est insérée
    ' et les champs listés dans nomsChamps dupliqués.
    '
    Dim i As Long, j As Long, lig As Long, nbLig As Long, nbAjout As Long, derCol As Long
    Dim libelErreur As String
    ' changer la dimension de posChamps si le nombre de champs à dupliquer change
    ' et mettre à jour la liste des libellés des champs
    Dim nomsChamps(), posChamps(4) As Long
    ' liste des libellés des champs, champ Date obligatoire et toujours en 1er
    nomsChamps = Array("Date", "Methode", "CodeSecteur", "Stratégie") ' 1er champ: Date, autres champs: champs à récupérer
    '
    '
    Application.ScreenUpdating = False ' ne pas rafraichir l'écran
    ' recup positions champs
    libelErreur = "champ " & nomsChamps(i) & " non trouvé."
    For i = 0 To UBound(nomsChamps)
        On Error GoTo erreur
        posChamps(i) = Application.Match(nomsChamps(i), [1:1], 0)
        On Error GoTo 0
    Next i
    ' trier par date
    derCol = [A1].Offset(1, Cells.Columns.Count - 1).End(xlToLeft).Column
    Columns("A:A").Resize(, derCol).Sort Key1:=Range("C2"), Order1:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, Orientation:=xlTopToBottom
    '
    ' pour chaque cellule colonne Date en partant de la dernière cellule remplie
    nbLig = [A1].Offset(Cells.Rows.Count - 1, posChamps(0) - 1).End(xlUp).Row
    For lig = nbLig To 3 Step -1
        If Cells(lig, posChamps(0)) > Cells(lig - 1, posChamps(0)) + 1 Then 'si delta date > 1 alors
            nbAjout = nbAjout + 1
            If nbLig + nbAjout > Cells.Rows.Count Then  ' si feuille trop petite
                libelErreur = "Trop de lignes ajoutées."
                GoTo erreur
            Else                                        ' sinon
                Application.StatusBar = "Ligne en cours de traitement : " & lig & " ( " & nbAjout & " lignes ajoutées)"
                Rows(lig).Insert Shift:=xlDown ' insérer 1 ligne au dessus
                Cells(lig, posChamps(0)).Value = Cells(lig + 1, posChamps(0)).Value - 1 ' mettre date-1
                For j = 1 To UBound(posChamps) - 1 ' inscrire les champs à récupérer
                    Cells(lig, posChamps(j)).Value = Cells(lig - 1, posChamps(j)).Value
                Next j ' champ suivant
                lig = lig + 1
            End If
        End If
    Next lig ' ligne suivante
    ' retablir barre d'état et rafraichissement écran
    Application.StatusBar = ""
    Application.ScreenUpdating = True
    MsgBox (nbAjout & " lignes ajoutées")
    Exit Sub
erreur:
    j = MsgBox(libelErreur, vbCritical + vbRetryCancel)
    Application.StatusBar = ""
    Application.ScreenUpdating = True
End Sub