XL 2019 Création d'une macro permettant la création automatique de fichiers CSV

Sub SSDoublons()
  Set mondico = CreateObject("Scripting.Dictionary")
      ActiveSheet.Range("aa1:aa100").ClearContents
  For Each c In Range("h1", [h65000].End(xlUp))
    mondico.Item(c.Value) = mondico.Item(c.Value) + 1
  Next c
  [aa1].Resize(mondico.Count, 1) = Application.Transpose(mondico.keys)
End Sub

Sub vraifaux()
Dim f1 As Worksheet, f2 As Worksheet
Set f1 = Sheets("data")
Set f2 = Sheets("csv")
Application.ScreenUpdating = False
Call SSDoublons
    f1.Select
        With f1
          .Range("ab1:ab1000").ClearContents
            lig1 = f1.Cells(f1.Rows.Count, 27).End(xlUp).Row
                lig2 = f1.Cells(f1.Rows.Count, 7).End(xlUp).Row
                    For Z = 4 To lig1
                        For x = 2 To lig2
                                 If f1.Cells(Z, 27) = f1.Cells(x, 8) Then
                                 f1.Cells(x, 28) = f1.Cells(x, 8)
                                 f1.Cells(1, 28) = f1.Cells(Z, 27)
                            End If
                         Next x
                    Call planning
                f1.Range("ab1:ab1000").ClearContents
            Next Z
        End With
  Application.ScreenUpdating = True
End Sub

Sub planning()
Dim f1 As Worksheet, f2 As Worksheet
Set f1 = Sheets("data")
Set f2 = Sheets("csv")

f2.Select
 With f2

.Range("a1:T1000").ClearContents

  lig2 = f1.Cells(f1.Rows.Count, 8).End(xlUp).Row
 
   
        For x = 2 To lig2
           y = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
         
           f2.Cells(1, 1) = f1.Cells(1, 28)
     
            If f1.Cells(x, 28) = f1.Cells(x, 8) Then '
            .Cells(y, 1) = f1.Cells(x, 1)
               .Cells(y, 2) = f1.Cells(x, 2)
                .Cells(y, 3) = f1.Cells(x, 3)
                    .Cells(y, 4) = f1.Cells(x, 4)
                        .Cells(y, 5) = f1.Cells(x, 5)
                            .Cells(y, 6) = f1.Cells(x, 6)
                                .Cells(y, 7) = f1.Cells(x, 7)
             
                 End If
             Next x
    End With

Call SaveAsCSV
  Application.ScreenUpdating = True
 f1.Select
End Sub

Sub SaveAsCSV()
On Error Resume Next
Dim wb As Workbook, ws As Worksheet
Dim strPath As String, strFilename As String, compteur As Long
nom = Sheets("csv").Cells(1, 1)
ct = Sheets("data").Cells(1, 29)
    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("csv")
    strPath = wb.Path & Application.PathSeparator
    strFilename = nom & "." & ct & ".csv"
    ws.Copy
    With ActiveWorkbook
        .SaveAs Filename:=strPath & strFilename, _
                FileFormat:=xlCSV, _
                local:=True '? adapter
        .Close savechanges:=False
    End With
    ct = ct + 1
    Sheets("data").Cells(1, 29) = ct
End Sub