Macro de création de fichier qui oublie une ligne de titre

Bonjour, j'ai récupéré du code qui me permet de créer dans un répertoire de mon disque C, autant de fichiers qu'il y a de valeurs différents en colonne A.
ça, ça marche.
Mais pourquoi la ligne 3 des jours datés n'est pas reprise dans chacun des fichiers ?
Fichier de base en pj.
Code vba utilisé (c'est de l'adaptation, vu que mon niveau ne me permet pas de tout piger) :

Sub Macro12()
Dim nwbk As Workbook
Dim dl&, dc%, i&, iDeb&, iFn&
Dim ws As Worksheet, R As Range, iCl%
On Error Resume Next
Application.DisplayAlerts = False
Sheets("edit97").Select
With ActiveSheet
Set R = .Range([A4], .[A65536].End(xlUp))
On Error GoTo 0
If R Is Nothing Then Exit Sub
iCl = R.Column
Application.ScreenUpdating = False
Application.EnableEvents = False
dl = .Cells(Rows.Count, "A").End(xlUp).Row
dc = .Cells(4, Columns.Count).End(xlToLeft).Column
.Range(.Cells(4, 1), .Cells(dl, dc)).Sort Key1:=.Cells(4, iCl), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
iDeb = 4
For i = 4 To dl
If .Cells(i, iCl).Value <> .Cells(i + 1, iCl).Value Then
iFn = i
Workbooks.Add xlWBATWorksheet
Set nwbk = ActiveWorkbook
Set ws = nwbk.Sheets(1)
On Error Resume Next
ws.Name = .Cells(iDeb, iCl).Text
On Error GoTo 0
ws.Range(Cells(1, 1), Cells(1, dc)).Value = .Range(.Cells(1, 1), .Cells(1, dc)).Value
.Range(.Cells(iDeb, 1), .Cells(iFn, dc)).Copy ws.Range("A4")
nwbk.SaveAs "C:\Bob_eff\" & ws.Name
nwbk.Close True
iDeb = iFn + 1
End If
Next i
End With
End Sub

***
Grand MERCi d'avance.