Exporter en CSV

Bonjour à tous !

@davidl : Votre "message" est tout simplement consternant.....

Bonjour à tous,

J'espère que quelqu'un viendra à mon secours.

En pièce jointe, vous trouverez une macro qui permet:

- de créer un ficher . XLS en fonction des différentes modalités de la seconde colonne nommée "Etablissement"

- d'intégrer toutes les lignes correspondantes au même établissement dans chaque fichier

- De nommer le fichier en fonction de l'établissement

Cependant, je souhaiterais le mettre au format CSV avec séparateur point virgule.

Quand j'utilise FileExtStr pour le mettre en csv, je n'arrive pas à retrouver le FileFormatNum qui correspond à un "enregistrer sous " au format csv "avec séparateur point virgule"

Pourriez-vous me l'indiquer s'il vous plaît?

Voici mon code que vous pouvez trouver dans la pièce jointe:

Option Explicit
'Option Private Module

Public Sub CopyToWorkbooks()
Dim wb As Workbook
Dim ws As Worksheet, ws2 As Worksheet, WSNew As Worksheet
Dim lo As ListObject
Dim Cell As Range
Dim Lrow As Long, FileFormatNum As Long, FieldNum As Long
Dim sFolderName As String, sPath As String, FileExtStr As String
Dim fso As Object
Dim CalcMode As XlCalculation

Set wb = ActiveWorkbook
Set ws = wb.ActiveSheet
Set lo = ws.ListObjects(1)
FieldNum = 2

If lo.ShowAutoFilter Then
lo.AutoFilter.ShowAllData
End If

FileExtStr = ".xlsx": FileFormatNum = 51

With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
.ScreenUpdating = False
'.EnableEvents = False
End With

On Error Resume Next
wb.Worksheets("Temp").Delete
On Error GoTo 0

Set ws2 = wb.Worksheets.Add(after:=Sheets(Sheets.Count))
ws2.Name = "Temp"

sPath = wb.Path & Application.PathSeparator
sFolderName = sPath & "Etablissement"
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.folderexists(sFolderName) Then
fso.deletefolder (sFolderName)
End If
MkDir sFolderName & Application.PathSeparator

With ws2
lo.ListColumns(FieldNum).Range.AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("A1"), Unique:=True
Lrow = .Cells(Rows.Count, "A").End(xlUp).Row
For Each Cell In .Range("A2:A" & Lrow)
lo.Range.AutoFilter Field:=FieldNum, Criteria1:="=" & Cell.Value
Set WSNew = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
lo.Range.SpecialCells(xlCellTypeVisible).Copy
With WSNew.Range("A1")
.PasteSpecial xlPasteColumnWidths
.PasteSpecial xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
.Select
End With
With WSNew
.ListObjects.Add(xlSrcRange, .Cells(1, 1).CurrentRegion, , xlYes).Name = "tbl_" & Cell.Value
.ListObjects(1).TableStyle = "TableStyleLight8"
End With
WSNew.Parent.SaveAs sFolderName & Application.PathSeparator & Cell.Value & FileExtStr, FileFormatNum
WSNew.Parent.Close False
lo.Range.AutoFilter Field:=FieldNum
Next Cell
.Delete
End With

With Application
.DisplayAlerts = True
.ScreenUpdating = True
'.EnableEvents = True
.Calculation = CalcMode
End With

Set fso = Nothing
Set lo = Nothing
Set WSNew = Nothing: Set ws2 = Nothing: Set ws = Nothing
Set wb = Nothing

End Sub

Je suis sincèrement désolé pour mon message consternant mais je n'arrivais pas à écrire de message après avoir mis la pièce jointe.

Et le temps que je vous sollicite clairement, vous m'avez répondu.

Je vous souhaite tout de même une bonne lecture.

Information supplémentaire:

Quand j'utilise FileExtStr pour le mettre en csv, je n'arrive pas à retrouver le FileFormatNum qui correspond à un "enregistrer sous " au format csv "avec séparateur point virgule".

En fait, j'y arrive mais pas avec les mêmes caractéristiques que manuellement.

En vous remerciant vivement par avance.

Bonjour à tous de nouveau !

Je vous remercie de ces précisions.....

Et vous souhaite la bienvenue sur le forum.

Nul doute que les nombreux spécialistes VBA du forum vous proposeront une solution.

Bonne continuation !

Bonjour davidl, le fil, le forum,

Un essai :
2 lignes ont été modifiées. Chercher : ''' << Bizz

Public Sub CopyToWorkbooks()
   Dim wb As Workbook
   Dim ws As Worksheet, ws2 As Worksheet, WSNew As Worksheet
   Dim lo As ListObject
   Dim Cell As Range
   Dim Lrow As Long, FileFormatNum As Long, FieldNum As Long
   Dim sFolderName As String, sPath As String, FileExtStr As String
   Dim fso As Object
   Dim CalcMode As XlCalculation

   Set wb = ActiveWorkbook
   Set ws = wb.ActiveSheet
   Set lo = ws.ListObjects(1)
   FieldNum = 2

   If lo.ShowAutoFilter Then
      lo.AutoFilter.ShowAllData
   End If

   ''    FileExtStr = ".xlsx": FileFormatNum = 51
   FileExtStr = ".csv": FileFormatNum = xlCSV  ''' << Bizz

   With Application
      CalcMode = .Calculation
      .Calculation = xlCalculationManual
      .DisplayAlerts = False
      .ScreenUpdating = False
      '.EnableEvents = False
   End With

   On Error Resume Next
   wb.Worksheets("Temp").Delete
   On Error GoTo 0

   Set ws2 = wb.Worksheets.Add(after:=Sheets(Sheets.Count))
   ws2.Name = "Temp"

   sPath = wb.Path & Application.PathSeparator
   sFolderName = sPath & "Etablissement"
   Set fso = CreateObject("Scripting.FileSystemObject")
   If fso.folderexists(sFolderName) Then
      fso.deletefolder (sFolderName)
   End If
   MkDir sFolderName & Application.PathSeparator

   With ws2
      lo.ListColumns(FieldNum).Range.AdvancedFilter _
         Action:=xlFilterCopy, _
         CopyToRange:=.Range("A1"), Unique:=True
      Lrow = .Cells(Rows.Count, "A").End(xlUp).Row
      For Each Cell In .Range("A2:A" & Lrow)
         lo.Range.AutoFilter Field:=FieldNum, Criteria1:="=" & Cell.Value
         Set WSNew = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
         lo.Range.SpecialCells(xlCellTypeVisible).Copy
         With WSNew.Range("A1")
            .PasteSpecial xlPasteColumnWidths
            .PasteSpecial xlPasteValuesAndNumberFormats
            Application.CutCopyMode = False
            .Select
         End With
         With WSNew
            .ListObjects.Add(xlSrcRange, .Cells(1, 1).CurrentRegion, , xlYes).Name = "tbl_" & Cell.Value
            .ListObjects(1).TableStyle = "TableStyleLight8"
         End With
         WSNew.Parent.SaveAs sFolderName & Application.PathSeparator & _
            Cell.Value & FileExtStr, FileFormatNum, local:=True, _
            CreateBackup:=False  ''' << Bizz

         WSNew.Parent.Close False

         lo.Range.AutoFilter Field:=FieldNum
      Next Cell
      .Delete
   End With

   With Application
      .DisplayAlerts = True
      .ScreenUpdating = True
      '.EnableEvents = True
      .Calculation = CalcMode
   End With

   Set fso = Nothing
   Set lo = Nothing
   Set WSNew = Nothing: Set ws2 = Nothing: Set ws = Nothing
   Set wb = Nothing

End Sub

Bizz

Bonjour à tous,

J'espère que cela va fonctionner. En fait, je dois intégrer les fichiers créés dans un logiciel qui n'accepte que les fichiers csv avec séparateur point virgule.

Cette opération va se faire la semaine prochaine.

De toute façon, je vous remercie vivement pour votre amabilité et votre efficacité.

Bonne journée!