creation d'un fichier csv a partir d'un doc excel sur plusieurs feuilles

Question

Bonjour,

j'ai recupere ce code pour exporter une feuille Excel en format de fichier CSV.
il parcours toutes les feuilles mais il ecrase a chaque nouvelle feuilles les donn&#233;es precedentes dans le nouveau fichier.
quelqu'un aurait-il une id&#233;e? une simple piste?
 je seche...

Private Sub BtOK_Click()


Dim temp As Boolean
Dim Resultat As Boolean
Dim i As Long
Dim Feuille As Worksheets
Resultat = True
MsgBox Worksheets.Count


For i = 1 To Worksheets.Count


    temp = fExportCommaDelimitedFile(Worksheets(i), "Donnees.csv")    If temp False Then Resultat False
    
Next i


    If (Resultat = False) Then
    MsgBox ("Erreur lors du la cr&#233;ation du fichier csv")
    End If
        
End Sub



'*********************** Code Start ***************************
Function fExportCommaDelimitedFile(objSht As Excel.Worksheet, strDestinationFile As String) As Boolean
'*******************************************
'Nom:      fExportCommaDelimitedFile (Function)
'But:   &#201;crire une feuille en format CSV
'Auteur:    Dev Ashish
'Date:        March 10, 1999, 12:21:10 PM
'Called by: Any
'Calls:        sAppActivate
'Inputs:      objSht - Feuille Excel d&#233;j&#224; ouverte, par automation
'                 strDestinationFile - Chemin de la destionation pour le fichier CSV
'Output:    True si tout est correct,  false autrement
'*******************************************
Dim intFileNum As Integer
Dim lngColCount As Long
Dim lngTotalColumns As Long
Dim lngTotalRows As Long
Dim lngRowCount As Long
Const conQ = """"
Const conERR_GENERIC = vbObjectError + 2100


  intFileNum = FreeFile()
  On Error GoTo ErrHandler
  
  'Active l'instance d'Access
  Call sAppActivate
  
  'Si le fichier cible existe, demander confirmation avant d'&#233;craser
  If Len(Dir(strDestinationFile)) > 0 Then
    If MsgBox("Le fichier de destination existe d&#233;j&#224; " & vbCrLf & vbCrLf & strDestinationFile & vbCrLf & vbCrLf & vbCrLf & vbCrLf & "Etes-vous s&#251;r de vouloir l'effacer?", vbQuestion + vbYesNo, "confirmer svp") = vbYes Then
          'Kill strDestinationFile
    Else
      Err.Raise conERR_GENERIC
    End If
  End If
   
  'Cr&#233;er le fichier CSV
  Open strDestinationFile For Output As #intFileNum
         
  With objSht
    'D&#233;terminer le nombre de colonnes
    lngTotalColumns = .UsedRange.Columns.Count
    'D&#233;terminer le nombre de lignes
    lngTotalRows = .UsedRange.Rows.Count
   'Traverser toutes les lignes
    For lngRowCount = 1 To lngTotalRows
      ' et chaque colonne
      For lngColCount = 1 To lngTotalColumns
        ' &#201;crire le texte de la cellule, avec guillements
        If RTrim$(.Cells(lngRowCount, lngColCount).Value) <> "" Then
            Print #intFileNum, conQ & RTrim$(.Cells(lngRowCount, lngColCount).Value) & conQ;
            ' V&#233;rifier si c'est la derni&#232;re colonne
            If lngColCount = lngTotalColumns Then
            'la fin
            Print #intFileNum,
            Else
            ' autrement, ajouter une virgule
            Print #intFileNum, ",";
            End If
        End If
      Next lngColCount
      DoEvents
    Next lngRowCount
  End With
  fExportCommaDelimitedFile = True
ExitHere:
  On Error Resume Next
 ' Call SysCmd(acSysCmdRemoveMeter)
  Close #intFileNum
  Exit Function
ErrHandler:
  fExportCommaDelimitedFile = False
  Resume ExitHere
End Function


Private Sub sAppActivate()
'Active l'intance d'Access
'
Dim strCaption As String
  On Error Resume Next
  strCaption = Application.CurrentDb.Properties("AppTitle")
  If Err Then strCaption = "Microsoft Access"
  AppActivate strCaption
End Sub
'*********************** Code End ***************************

elog29 · Answer

Open strDestinationFile For ~~Output~~ Append As #intFileNum

Creation d'un fichier csv a partir d'un doc excel sur plusieurs feuilles

1 réponse

Discussions similaires