Dupliquer ligne avec condition

Sub Duplique()
Dim TE(), LE&, TS(), LS&, C&
TE = ActiveSheet.[A1].CurrentRegion.Value
ReDim TS(1 To 5000, 1 To 6)
For LE = 2 To UBound(TE, 1)
   LS = LS + 1
   For C = 1 To 6: TS(LS, C) = TE(LE, C): Next C
   If Not IsEmpty(TE(LE, 7)) Then
      LS = LS + 1
      For C = 1 To 5: TS(LS, C) = TE(LE, C): Next C
      TS(LS, 6) = TE(LE, 7): End If: Next LE
ActiveSheet.[A14].Resize(LS, 6).Value = TS
End Sub

Sub dupliqueCA()
Dim tablo()
With Sheets("Feuil2")
.[J:O].EntireColumn.ClearContents
.[A1:F1].Copy .[J1]
For lig = 2 To .Cells(Rows.Count, 2).End(xlUp).Row
    For col = 1 To 2
        If .Cells(lig, 5 + col) <> "" Then
            ReDim Preserve tablo(5, i)
            tablo(0, i) = .Cells(lig, 1)
            tablo(1, i) = .Cells(lig, 2)
            tablo(2, i) = .Cells(lig, 3)
            tablo(3, i) = .Cells(lig, 4)
            tablo(4, i) = .Cells(lig, 5)
            tablo(5, i) = .Cells(lig, 5 + col)
            i = i + 1
        End If
    Next col
Next lig
.[J2].Resize(i, 6) = Application.Transpose(tablo)
End With
End Sub

Sub dupliqueCA()
Dim tablo()
With Sheets("Feuil2")
titres = Array("civilite", "nom", "nom de jeune fille", "prenom", "date naissance", "CA")
For lig = 2 To .Cells(Rows.Count, 2).End(xlUp).Row
    For col = 1 To 2
        If .Cells(lig, 5 + col) <> "" Then
            ReDim Preserve tablo(5, i)
            tablo(0, i) = .Cells(lig, 1)
            tablo(1, i) = .Cells(lig, 2)
            tablo(2, i) = .Cells(lig, 3)
            tablo(3, i) = .Cells(lig, 4)
            tablo(4, i) = .Cells(lig, 5)
            tablo(5, i) = .Cells(lig, 5 + col)
            i = i + 1
        End If
    Next col
Next lig
.[A:G].EntireColumn.ClearContents
.[A1:F1] = titres
.[A2].Resize(i, 6) = Application.Transpose(tablo)
End With
End Sub: