création automique de fichier CSV par ligne du fichier d'origine

Sub FichiersCSV()
Dim t#, chemin$, nomfich$, dossier$, d As Object, c As Range, x
t = Timer
chemin = ThisWorkbook.Path & "\"
nomfich = "SourceCSV.csv" 'à adapter
dossier = "Fichiers CSV\" 'dossier réceptacle
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
MkDir chemin & dossier 'création du dossier s'il n'existe pas
With Workbooks.Open(chemin & nomfich).Sheets(1)
  Workbooks.Add 'nouveau document
  .Rows(1).Copy [A1]
  Set d = CreateObject("Scripting.Dictionary")
  For Each c In .[A:A].SpecialCells(xlCellTypeConstants)
    x = Split(c, ";")(3)
    If c.Row > 1 And Not d.exists(x) Then
      d(x) = ""
      [A2] = ";;;" & x
      ActiveWorkbook.SaveAs chemin & dossier & x, xlCSV
    End If
  Next
  ActiveWorkbook.Close False
  .Parent.Close False
End With
MsgBox "Durée " & Format(Timer - t, "0.0 \s")
End Sub

[A2] = ";;;" & x

[A2] = c

Sub FichiersCSV_25_premiers()
Dim t#, N&, chemin$, nomfich$, dossier$, d As Object
Dim c As Range, x, lig&, c1 As Range
t = Timer
N = 25 'nombre maximum de fichiers à créer
chemin = ThisWorkbook.Path & "\"
nomfich = "test.csv" 'à adapter
dossier = "Fichiers CSV 25 premiers\" 'dossier réceptacle
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
MkDir chemin & dossier 'création du dossier s'il n'existe pas
With Workbooks.Open(chemin & nomfich).Sheets(1)
  Workbooks.Add 'nouveau document
  .Rows(1).Copy [A1]
  Set d = CreateObject("Scripting.Dictionary")
  For Each c In .[A:A].SpecialCells(xlCellTypeConstants)
    x = Split(c, ";")(3)
    If c.Row > 1 And Not d.exists(x) Then
      d(x) = ""
      Range("A2:A" & Rows.Count).ClearContents 'RAZ
      lig = 2
      For Each c1 In .[A:A].SpecialCells(xlCellTypeConstants)
        If Split(c1, ";")(3) = x Then
          Cells(lig, 1) = c1
          lig = lig + 1
        End If
      Next
      ActiveWorkbook.SaveAs chemin & dossier & x, xlCSV
      If d.Count = N Then Exit For
    End If
  Next
  ActiveWorkbook.Close False
  .Parent.Close False
End With
MsgBox "Durée " & Format(Timer - t, "0.0 \s")
End Sub

Sub FormatageValeursNumeriquesColonneD()
Dim fichier$, c As Range, s
fichier = ThisWorkbook.Path & "\test.csv" 'à adapter
Application.ScreenUpdating = False
On Error Resume Next
With Workbooks.Open(fichier)
  For Each c In .Sheets(1).[A:A].SpecialCells(xlCellTypeConstants)
    s = Split(c, ";")
    If IsNumeric(s(3)) Then
      's(3) = "'0" & CDbl(s(3))
      s(3) = Format(s(3), "'0000000")
      c = Join(s, ";")
    End If
  Next
  .Close True
End With
End Sub

'--------
      If IsNumeric(x) Then x = Format(x, "0000000") 'formatage du nom
      ActiveWorkbook.SaveAs chemin & dossier & x, xlCSV

'--------
      On Error Resume Next
      ActiveWorkbook.SaveAs chemin & dossier & x, xlCSV
      If Err Then MsgBox x

'--------
      x = Replace(x, ":", "#") 'caractère interdit
      ActiveWorkbook.SaveAs chemin & dossier & x, xlCSV