Microsoft 365 *Resolu* VBA, Conversion en CSV sans derniere virgule

alecuyer

XLDnaute Nouveau
Bonjour à toutes et tous,

Je suis dans une impasse et voudrait bien de l'aide sur ce coup là.
J'ai trouvé ce code permettant de convertir plusieurs onglets en CSV. C'était parfait, nickel, rien à dire !
VB:
Option Explicit
Sub creer_CSV()


'================================================================
'              Exportation de feuilles en fichiers .CSV
'================================================================
Dim I&, j&, k&, Num&, Num2&
Dim Mes$, Fic$, Chem$, Separ$, All$
Dim Plg As Variant
Dim F As Worksheet
'================================================================
'                           Paramétrage
'================================================================
'Sufixe du fichier (èvite l'écrasement des fichiers précédents)
'Les fichiers porteront le nom des feuilles correspondantes plus le suffixe
Fic = "_" & Format(Date, "dd-mm-yyyy") & "_" & Format(Time, "h""H""mm") & ".csv"
'Chemin du dossier où seront crées les fichiers
' / ! \ Le chemin doit déja exister / ! \
Chem = "C:\temp"
'Séparateur utilisé pour la création des .CSV
Separ = ","
'Nom du fichier global
All = "All Gift Card"
'================================================================
'                           Traitement
'================================================================
'récupération d'un numéro de fichier non utilisé
Num = FreeFile
'Ouverture d'un fichier qui nous servira comme fichier global
Open Chem & "\" & All & Fic For Output As #Num
'Pour chaque feuille présentent dans le classeur actif
For Each F In ActiveWorkbook.Worksheets
    'récupération d'un numéro de fichier non utilisé
    Num2 = FreeFile
    'Déclaration de la valeur du tableau
    '(toute les données présentent sur la feuille)
    Plg = F.Range("A1").CurrentRegion.Value
    'Ouverture d'un fichier au nom de la feuille
    Open Chem & "\" & F.Name & Fic For Output As #Num2
        'Pour chaque ligne du tableau, sauf la première (+ 1) pour ne pas prendre les en tête de colonnes
        For I = LBound(Plg, 1) + 1 To UBound(Plg, 1)
            'Pour chaque colonne du tableau
            For j = LBound(Plg, 2) To UBound(Plg, 2)
                'Le message est ègal au message plus la valeur de la cellule
                ' en ligne i colonne j plus le séparateur ";"
                Mes = Mes & Plg(I, j) & Separ
            'Prochaine colonne
            Next j
            'Ecriture du message dans le fichier global
            Print #Num, Mes
            'Ecriture du message dans le fichier au nom de la feuille
            Print #Num2, Mes
            'Vide le message avant de passer à la ligne suivante
            Mes = ""
        'Ligne suivante
        Next I
    'Quand la boucle sur toutes les lignes du tableau est terminée
    'Fermeture du fichier au nom de la feuille
    Close #Num2
    'Suppression du tableau qui sera recréé à la prochaine feuille
    Erase Plg
'Prochaine feuille
Next F
'Fermeture du fichier global
Close #Num
'================================================================
'Boite de message pour la fin du traitement
MsgBox "Fichiers convertis en CSV dans C: Temp"
End Sub

Seulement je me suis aperçu que l'appli dans laquelle je doit uploder les données CSV n'accepte pas la dernière virgule (à la fin de la chaine).
J'ai ne trouve pas de solution

j'ai essayé avec ça
Code:
Sub sup_der_espace()
           Dim Rg As Range
        Application.ScreenUpdating = False
    With Cells(1).CurrentRegion.Columns(1)
           Set Rg = .Find("*,", , xlValues, xlWhole)
        If Not Rg Is Nothing Then
            Do
                 Rg.Value = Left(Rg.Value, Len(Rg.Value) - 1)
                   Set Rg = .FindNext(Rg)
            Loop Until Rg Is Nothing
        End If
    End With
        Application.ScreenUpdating = True
End Sub

Ca marche bien aussi mais... séparement.

Je souhaiterai que tout se fasse dans la même action. Ou alors que la 1ere macro ne me mette pas de virgule à la fin de la ligne.

Please, j'ai besoin de votre aide. :)
Merci
Aymeric
 

patricktoulon

XLDnaute Barbatruc
re
sans approfondir car perso j'utilise une autre methode
je dirais
Mes = Mes & Plg(I, j) & iff( trim(Plg(I, j)) <>"",separ,"")
a condition que tu n'ai pas de cellules vides entre 2

il y aurais aussi une autre solution avec tes boucles ce serait de transcrire
le join (de la ligne (cells(1) cells xltoright),";") avec un test countblanck peut etre ;)
 

patricktoulon

XLDnaute Barbatruc
bonjour
je te propose pour la construction de tes ligne du csv de boucler une seule fois
une seule fois sur les lignes
deja on gagne en rapidité
a chaque ligne on la récupere en entier sous la forme d'un tableau a 2 dim(1 ligne ,x colonne)
ce tableau d'une seule ligne est converti en array (tableau 1 dim)
tu join cet array par le separateur que tu veux
tu a ainsi chaque ligne avec les données séparées par le separateur
et tu n'a pas le séparateur a la fin MÊME!!! SI !!! LES LIGNES N'ONT PAS LE MÊME NOMBRE DE COLONNES
et tout ca en 4 /5 lignes de code pour ce qui est du moteur pour ce principe

un petit exemple

VB:
Sub test3()
   Dim plage As Range, L&, Dercol&, ligne$
   Set plage = Feuil1.[A1].CurrentRegion
    With plage
        For L = .Row To .Rows.Count + .Row - 1
            Dercol = Cells(L, Columns.Count).End(xlToLeft).Column
            If Dercol > 1 Then
                  ligne = Join(Application.Index(Range(.Cells(L, .Column), Cells(L, Dercol)).Value, 1, 0), ";")
            Else
                ligne = Cells(L, 1)
            End If
            Debug.Print ligne
        Next
    End With
End Sub

regarde le texte dans le debug
;)
 

job75

XLDnaute Barbatruc
Bonjour à tous,

Dans la macro il suffit d'ajouter ce petit code :
VB:
            For j = Len(Mes) To 1 Step -1
                'supprime les séparateurs situés à la fin du texte
                If Mid(Mes, j, 1) = Separ Then Mes = Left(Mes, j - 1) Else Exit For
            Next j
La macro complétée :
Code:
Option Explicit
Sub creer_CSV()


'================================================================
'              Exportation de feuilles en fichiers .CSV
'================================================================
Dim I&, j&, k&, Num&, Num2&
Dim Mes$, Fic$, Chem$, Separ$, All$
Dim Plg As Variant
Dim F As Worksheet
'================================================================
'                           Paramétrage
'================================================================
'Sufixe du fichier (èvite l'écrasement des fichiers précédents)
'Les fichiers porteront le nom des feuilles correspondantes plus le suffixe
Fic = "_" & Format(Date, "dd-mm-yyyy") & "_" & Format(Time, "h""H""mm") & ".csv"
'Chemin du dossier où seront crées les fichiers
' / ! \ Le chemin doit déja exister / ! \
Chem = "C:\temp"
'Séparateur utilisé pour la création des .CSV
Separ = ","
'Nom du fichier global
All = "All Gift Card"
'================================================================
'                           Traitement
'================================================================
'récupération d'un numéro de fichier non utilisé
Num = FreeFile
'Ouverture d'un fichier qui nous servira comme fichier global
Open Chem & "\" & All & Fic For Output As #Num
'Pour chaque feuille présentent dans le classeur actif
For Each F In ActiveWorkbook.Worksheets
    'récupération d'un numéro de fichier non utilisé
    Num2 = FreeFile
    'Déclaration de la valeur du tableau
    '(toute les données présentent sur la feuille)
    Plg = F.Range("A1").CurrentRegion.Value
    'Ouverture d'un fichier au nom de la feuille
    Open Chem & "\" & F.Name & Fic For Output As #Num2
        'Pour chaque ligne du tableau, sauf la première (+ 1) pour ne pas prendre les en tête de colonnes
        For I = LBound(Plg, 1) + 1 To UBound(Plg, 1)
            'Pour chaque colonne du tableau
            For j = LBound(Plg, 2) To UBound(Plg, 2)
                'Le message est ègal au message plus la valeur de la cellule
                ' en ligne i colonne j plus le séparateur
                Mes = Mes & Plg(I, j) & Separ
            'Prochaine colonne
            Next j
            For j = Len(Mes) To 1 Step -1
                'supprime les séparateurs situés à la fin du texte
                If Mid(Mes, j, 1) = Separ Then Mes = Left(Mes, j - 1) Else Exit For
            Next j
            'Ecriture du message dans le fichier global
            Print #Num, Mes
            'Ecriture du message dans le fichier au nom de la feuille
            Print #Num2, Mes
            'Vide le message avant de passer à la ligne suivante
            Mes = ""
        'Ligne suivante
        Next I
    'Quand la boucle sur toutes les lignes du tableau est terminée
    'Fermeture du fichier au nom de la feuille
    Close #Num2
    'Suppression du tableau qui sera recréé à la prochaine feuille
    Erase Plg
'Prochaine feuille
Next F
'Fermeture du fichier global
Close #Num
'================================================================
'Boite de message pour la fin du traitement
MsgBox "Fichiers convertis en CSV dans C: Temp"
End Sub
PS : pourquoi 2 fichiers CSV sont-ils créés ??? Pas cherché à comprendre !!!

A+
 

patricktoulon

XLDnaute Barbatruc
re
bonjour job75
PS : pourquoi 2 fichiers CSV sont-ils créés ??? Pas cherché à comprendre !!!
j'ai cru comprendre qu'il voulait une compil de tout les csv

perso un extrait de ma méthode que l'on trouve ici
VB:
Sub test2()
    [A1].CurrentRegion.Copy
    t = Replace(Replace(Replace(CreateObject("htmlfile").parentwindow.clipboardData.GetData("TEXT"), vbTab, ";"), ";;;", ""), ";;", "")
    t = Replace(t, ";" & vbCrLf, vbCrLf)
    Application.CutCopyMode = False    'on relache la plage copiée
    Debug.Print t
End Sub
  1. on copy la plage
  2. on la recupere dans le clip au format texte
  3. on remplace les vbtab par ";"
  4. on remplace les ";;;" et les ";;" (nombre pair et impair) par ";" et les ";" &vbcrlf par vbcrlf
  5. on débloque le copy
terminé on a notre code csv
 

alecuyer

XLDnaute Nouveau
Merci à tous pour votre participation, c'est vraiment super !!!;)

J'ai testé et ça fonctionne comme je voulais.

Effectivement, il y a plusieurs CSV car c'est un regroupement de plusieurs feuilles.

Par contre j'ai un autre souci :rolleyes:
Quand je les regroupe tous, soit j'ai autant d’entête de colonne dans mon CSV que d'onglet à regrouper, soit je n'en ai pas du tout.
Çà dépend si je laisse :

'Pour chaque ligne du tableau, sauf la première (+ 1) pour ne pas prendre les en tête de colonnes
For I = LBound(Plg, 1) + 1 To UBound(Plg, 1)
ou
'Pour chaque ligne du tableau, sauf la première (+ 1) pour ne pas prendre les en tête de colonnes
For I = LBound(Plg, 1) To UBound(Plg, 1)

L'un d'entre vous aurait il une solution pour que l'entête ne se recopie qu'une fois sur le fichier global ?
D'avance merci
Aymeric
 

alecuyer

XLDnaute Nouveau
Bonjour Patricktoulon,
En fait, j'ai un tableau global contenant une dizaine de lignes par exemple.
Dans la colonne A, des infos comme X, Y & Z.
Une autre macro me génère trois onglets différents X, Y & Z
Des collègues se charge de compléter ces 3 onglets, puis moi je les compile en CSV pour pouvoir les envoyer dans une application tiers.
 

job75

XLDnaute Barbatruc
Quand je les regroupe tous, soit j'ai autant d’entête de colonne dans mon CSV que d'onglet à regrouper, soit je n'en ai pas du tout.
Çà dépend si je laisse :

'Pour chaque ligne du tableau, sauf la première (+ 1) pour ne pas prendre les en tête de colonnes
For I = LBound(Plg, 1) + 1 To UBound(Plg, 1)
ou
'Pour chaque ligne du tableau, sauf la première (+ 1) pour ne pas prendre les en tête de colonnes
For I = LBound(Plg, 1) To UBound(Plg, 1)
Bien sûr pour copier la ligne des en-têtes il ne faut pas de + 1.

Et pour ne la copier qu'une seule fois dans le fichier global :
VB:
            'Ecriture du message dans le fichier global
            If I > 1 Then Print #Num, Mes Else If F.Index = 1 Then Print #Num, Mes
            'Ecriture du message dans le fichier au nom de la feuille
            Print #Num2, Mes
 

Discussions similaires