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

A

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
 
Trier par date Trier par votes
patricktoulon

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 ;)
 
Vote positif 0 Vote négatif
patricktoulon

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
;)
 
Vote positif 0 Vote négatif
job75

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+
 
Vote positif 0 Vote négatif
patricktoulon

patricktoulon

XLDnaute Barbatruc
re
bonjour job75
PS : pourquoi 2 fichiers CSV sont-ils créés ??? Pas cherché à comprendre !!!
Cliquez pour agrandir...
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
 
Vote positif 0 Vote négatif
A

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
 
Vote positif 0 Vote négatif
A

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.
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
alecuyer à dit:
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)
Cliquez pour agrandir...
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
 
Vote positif 0 Vote négatif

Discussions similaires

J
  • Question
XL 2021 excel - vbs - csv
2
Réponses
28
Affichages
1 K
jerome1980
J
cathodique
  • Résolu(e)
XL 2010 Problème màj feuilles depuis fichiers CSV
2
Réponses
23
Affichages
2 K
cathodique
cathodique
P
  • Question
XL 2019 Changer nom d'export en VBA
Réponses
3
Affichages
416
job75
job75
L
  • Question
Autres Copier des données d’un fichier sans l’ouvrir juste en le sélectionnant via un UserForm
Réponses
6
Affichages
632
Liner77
L
N
  • Question
Microsoft 365 Exporter en csv vers un sharepoint
Réponses
0
Affichages
382
Negalo
N
M
  • Résolu(e)
XL 2021 PUBLIPOSTAGE : Mise en forme du corps de message issu d'une cellule excel (VBA)
Réponses
4
Affichages
313
Minus&Cortex
M
G
  • Question
Microsoft 365 Export données
Réponses
4
Affichages
413
GClaire
G
C
  • Résolu(e)
XL 2016 Répartir dans des Groupes d'Effectifs Aléatoires ... mais pas trop
Réponses
2
Affichages
206
crocrocro
C
P
  • Résolu(e)
XL 2021 Besoin d'aide pour copier/coller données de plusieurs classeurs
2
Réponses
20
Affichages
530
Pac41240
P
L
  • Résolu(e)
Microsoft 365 Décompte via plusieurs fichiers CSV
Réponses
12
Affichages
572
WTF
WTF

Membres actuellement en ligne

3 membres et 65 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
314 499
Messages
2 110 250
Membres
110 711
dernier inscrit
chmessi