Macro bouton enregistrement en csv

Bonjour,

Je souhaite crée un bouton pour enregistré en .csv

Mais je souhaite qu'il m'enregistre en plusieur fichiers.

le permier fichier enregistre la ligne 1500 premiere ligne

le deuxieme fichier enregistre la ligne la ligne 1 avec les lignes de 1501 à 3000

le troisieme fichier enregistre la ligne 1 avec les les de 3001 à 4500

Le quatrieme fichier la ligne 1 à 4501 à 5000.

Bonjour,

Un essai ...

La dernière colonne est basée sur la ligne 1.

Il y a demande du nom de chacun des 4 fichiers .csv créés.

Sub ExportCSV()
Dim Fd As FileDialog
Dim strChaine As String
Dim Plage As Range
Dim Ligne As Long
Dim Colonne As Integer
Dim Dcol As Integer
Dim X As Integer

    Dcol = Cells(1, Columns.Count).End(xlToLeft).Column
    'Plage a trasformer en CSV
    Set Plage = Range(Cells(1, "A"), Cells(1, Dcol))    'Selection

' 3 premiers block
    For X = 1 To 4500 Step 1500

    'Fenêtre de choix d'emplacement et nom du fichier en sortie
    Set Fd = Application.FileDialog(msoFileDialogSaveAs)

    'Ajout du filtre
    Fd.FilterIndex = 5

    'Sortie si pas de fichier
    If Fd.Show = False Then Exit Sub

    'Ouverture du fichier de sortie
   Open Fd.SelectedItems(1) For Output As #1

    'Boucle sur la plage et ajoute les lignes au fichier
        For Ligne = X To X + 1500    ''Plage.Rows.Count
            For Colonne = 1 To Plage.Columns.Count
                If strChaine <> "" Then strChaine = strChaine & ";"
                strChaine = strChaine & Plage.Cells(Ligne, Colonne).Value
            Next Colonne
            Print #1, strChaine
            strChaine = ""
        Next Ligne
            'Fermeture du fichier
    Close #1
    MsgBox "Fichier : " & Fd.SelectedItems(1) & " disponible"

    Next X

'' ###################  dernier block 4501 to 5000
    'Fenêtre de choix d'emplacement et nom du fichier en sortie
    Set Fd = Application.FileDialog(msoFileDialogSaveAs)

    'Ajout du filtre
    Fd.FilterIndex = 5

    'Sortie si pas de fichier
    If Fd.Show = False Then Exit Sub

    'Ouverture du fichier de sortie
   Open Fd.SelectedItems(1) For Output As #1

        For Ligne = 4501 To 5000    ''Plage.Rows.Count
            For Colonne = 1 To Plage.Columns.Count
                If strChaine <> "" Then strChaine = strChaine & ";"
                strChaine = strChaine & Plage.Cells(Ligne, Colonne).Value
            Next Colonne
            Print #1, strChaine
            strChaine = ""
        Next Ligne

    'Fermeture du fichier
    Close #1
    MsgBox "Fichier : " & Fd.SelectedItems(1) & " disponible"
End Sub

ric

bonjour

salut ric

félicitations pour les commentaires dans ton code

petit détail : il manque juste un titre

amitiés à tous

Super travaille, merci

Mais effectivement il manque la ligne A pour chaque enregistrement.

Est il possible de o'enregistre automatique en donnant un nom comme ficher 1, 2, 3 ....

Merci

Bonjour,

Est-ce bien ... dans le InputBox > l'on saisit "le_nom" > qui deviendra "le_nom01" pour le premier segment, puis "le_nom02, puis "le_nom03 et enfin "le_nom04" ?

Est-ce que cela conviendrait ?

ric

Oui ça me convient

Merci

Il me manque qu'à trouve comme avoir la ligne 1 sur chaque fichier et à sera super.

Bonjour,

Ha! Ha! ... tes données ont des entêtes de colonnes ... ce qui n'avait pas été mentionné.

Je regarde en même temps que la modif pour les noms.

ric

Bonjour,

Pour l'instant, avec ce code glané sur le Net et adapté à ta demande, je sèche sur les noms semi-automatisés.

Ça a mieux été pour les entêtes de colonnes dans chacun des fichiers ...

Sub ExportCSV()
Dim Fd As FileDialog
Dim strChaine As String, StrEntete As String
Dim Plage As Range
Dim Ligne As Long
Dim Colonne As Integer
Dim Dcol As Integer
Dim X As Integer, Z As Byte
Dim NomFic As FileDialog

    Dcol = Cells(1, Columns.Count).End(xlToLeft).Column
    '''    Plage a trasformer en CSV
    Set Plage = Range(Cells(1, "A"), Cells(1, Dcol))    'Selection

    For Colonne = 1 To Plage.Columns.Count
        If StrEntete <> "" Then StrEntete = StrEntete & ";"
        StrEntete = StrEntete & Plage.Cells(1, Colonne).Value
    Next Colonne

''' 3 premiers block
    For X = 2 To 4500 Step 1500

        'Fenêtre de choix d'emplacement et nom du fichier en sortie
        Set Fd = Application.FileDialog(msoFileDialogSaveAs)

        'Ajout du filtre
        Fd.FilterIndex = 5

        'Sortie si pas de fichier
        If Fd.Show = False Then Exit Sub

        'Ouverture du fichier de sortie
        Open Fd.SelectedItems(1) For Output As #1

        '''    'Boucle sur la plage et ajoute les lignes au fichier
        Print #1, StrEntete

        For Ligne = X To X + 1499    ''Plage.Rows.Count
            For Colonne = 1 To Plage.Columns.Count
                If strChaine <> "" Then strChaine = strChaine & ";"
                strChaine = strChaine & Plage.Cells(Ligne, Colonne).Value
            Next Colonne
            Print #1, strChaine
            strChaine = ""
        Next Ligne
        'Fermeture du fichier
        Close #1
        MsgBox "Fichier : " & Fd.SelectedItems(1) & " disponible"

    Next X

'' ###################  dernier block 4501 to 5000
    'Fenêtre de choix d'emplacement et nom du fichier en sortie
    Set Fd = Application.FileDialog(msoFileDialogSaveAs)

    'Ajout du filtre
    Fd.FilterIndex = 5

    'Sortie si pas de fichier
    If Fd.Show = False Then Exit Sub

    'Ouverture du fichier de sortie
    Open Fd.SelectedItems(1) For Output As #1
    Print #1, StrEntete
    For Ligne = 4501 To 5001    ''Plage.Rows.Count
        For Colonne = 1 To Plage.Columns.Count
            If strChaine <> "" Then strChaine = strChaine & ";"
            strChaine = strChaine & Plage.Cells(Ligne, Colonne).Value
        Next Colonne
        Print #1, strChaine
        strChaine = ""
    Next Ligne

    'Fermeture du fichier
    Close #1
    MsgBox "Fichier : " & Fd.SelectedItems(1) & " disponible"
End Sub

Merci

Bonjour,

Une solution pour ne choisir qu'une fois le nom et l'emplacement pour les fichiers.csv

Le nom choisi sera renommé et incrémenté "01_", "02_", etc.

Un essai ...

Option Explicit

Sub ExportCSV()
Dim Fd As FileDialog
Dim strChaine As String, StrEntete As String
Dim Plage As Range
Dim Ligne As Long
Dim Colonne As Integer
Dim Dcol As Integer
Dim X As Integer, Z As Byte
Dim NomFich As String
Dim LeCsv As String
Dim FichSelect As Variant

    Dcol = Cells(1, Columns.Count).End(xlToLeft).Column ' dernière colonne

    '''    Entêtes de la plage à transformer en CSV
    Set Plage = Range(Cells(1, "A"), Cells(1, Dcol))    ' sélection des entêtes

    ''' mémorise les entêtes (ligne 1)
    For Colonne = 1 To Plage.Columns.Count  ' boucle sur les colonnes
        If StrEntete <> "" Then StrEntete = StrEntete & ";"
        StrEntete = StrEntete & Plage.Cells(1, Colonne).Value
    Next Colonne

    Z = 0

    ''' Fenêtre de choix d'emplacement et nom du fichier en sortie (nom temporaire)
    Set Fd = Application.FileDialog(msoFileDialogSaveAs)

    ''' Ajout du filtre
    Fd.FilterIndex = 5

    ''' Sortie si pas de fichier
    If Fd.Show = False Then Exit Sub

    ''' Ouverture du fichier de sortie
    Open Fd.SelectedItems(1) For Output As #1

    With Fd     ' ce bloc extrait le nom du fichier choisi afin de l'incrémenter
        For Each FichSelect In .SelectedItems
            LeCsv = Right(FichSelect, Len(FichSelect) - InStrRev(FichSelect, "\"))
            NomFich = FichSelect
        Next FichSelect
    End With
    Close #1    ' ferme le fichier choisi

    ''' ############# 3 premiers blocs
    For X = 2 To 4500 Step 1500  ' boucle sur les blocs de 1500 lignes
        Z = Z + 1

    ''' rouvre le fichier choisi
    Open Fd.SelectedItems(1) For Output As #1

        ''' ajoute les entêtes au fichier choisi
        Print #1, StrEntete

        For Ligne = X To X + 1499    ' boucle sur les blocs de 1500 lignes
            For Colonne = 1 To Plage.Columns.Count
                If strChaine <> "" Then strChaine = strChaine & ";"
                strChaine = strChaine & Plage.Cells(Ligne, Colonne).Value
            Next Colonne
            Print #1, strChaine     ' ajoute les données au fichier choisi
            strChaine = ""
        Next Ligne

        ''' Fermeture du fichier
        Close #1

        ''' renomme le fichier
        FileCopy NomFich, "0" & Z & "_" & LeCsv
        MsgBox "Fichier : " & "0" & Z & "_" & LeCsv & " disponible. "

    Next X  ' prochain bloc

''''' ###################  dernier bloc > 4501 to 5000

    ''' Ouverture du fichier de sortie
    Open NomFich For Output As #1

    Print #1, StrEntete         ' ajoute les entêtes
    For Ligne = 4501 To 5001    ' boucle sur les 500 dernières lignes
        For Colonne = 1 To Plage.Columns.Count
            If strChaine <> "" Then strChaine = strChaine & ";"
            strChaine = strChaine & Plage.Cells(Ligne, Colonne).Value
        Next Colonne
        Print #1, strChaine     ' ajoute les données
        strChaine = ""
    Next Ligne

    ''' Fermeture du fichier
    Close #1

    ''' renomme le fichier choisi
    FileCopy NomFich, "0" & Z + 1 & "_" & LeCsv
    MsgBox "Fichier : " & "0" & Z + 1 & "_" & LeCsv & " disponible. "

    '''  supprime le fichier temporaire
    Kill NomFich
End Sub

ric

Bonjour,

Vous avez fait un super travaille, je ne sais pas comment vous remercié.

Bonjour,

Vous avez fait un super travaille, je ne sais pas comment vous remercié.

Il propose un enregistrement CSV UFT-8 , je souhaiterai un enregistrement en CSV ( séparateur : point-virgule )

A quel endroit je dois changer pour mettre CSV ( séparateur : point-virgule )

Et encore merci, je n'aurai jamais pu y arrive sans vous, mille merci.

J'ai trouve grace a vos notes dans la macro

''' Ajout du filtre

Fd.FilterIndex = 16

Il suffit de changer le numuro du filtre par 16.

Bonjour

Je rouvre le sujet car j'ai un petit problème a l'application quand j'ai le signe ; dans une cellule cela me met tous dans une seul ligne.

Bonjour,

Pour supprimer tous les ";" avant de commencer le traitement, ajoute

Range(Cells(1, 1), Cells(5000, Dcol)).Replace What:=";", Replacement:="", _ SearchOrder:=xlByColumns, MatchCase:=True

au début, juste sous "Dcol = Cells(......."

ainsi ...

    Dcol = Cells(1, Columns.Count).End(xlToLeft).Column ' dernière colonne

    Range(Cells(1, 1), Cells(5000, Dcol)).Replace What:=";", Replacement:="", _
                 SearchOrder:=xlByColumns, MatchCase:=True

ric

Dans mon fichier, j'ai besoin de gardé le caractere " ; "il est indispensable dans mon fichier.

Bonjour,

Avec mon peu d'expérience, il devient difficile de conserver un ; quand le séparateur de champs est lui aussi le ;

Est-ce que tu aurais un fichier exemple afin de voir de quoi il retourne ?

ric

Ce sont des formles avec des ;

on peut peut etre les copier en texte avant de les les enregistré?

Bonjour,

Au risque de dire n'importe quoi > ce n'est pas tant à l'écriture du .csv qui est le problème, mais à sa lecture > en rencontrant les ; des formules, le lecteur va sauter automatiquement à la cellule suivante.

Les .csv créés ... est-ce primordial que le séparateur de champs soit le ; ???

ric

je viens de regarde , ce ne sont pas les formule mais le fait que j'ai dans une cellule un texte qui est html

Voici un exemple de texte

<h1 style="font-family: "Times New Roman"; text-align: center;"><span style="font-family: Helvetica;">Zipfire</span></h1><h1 style="font-family: "Times New Roman"; text-align: center;"><img src="https://www.google.fr/images/branding/googlelogo/2x/googlelogo_color_92x30dp.png" style="color: inherit; font-family: verdana, arial, helvetica, sans-serif; font-size: 13px; width: 400px; max-width: 100%;"><br></h1><h3><br></h3><h3><br></h3><h1 style="text-align: center;"><span style="font-size: 24px;">N</span></h1><h3><br></h3><h3><br></h3><h3><br></h3><h1 style="font-family: "Times New Roman"; text-align: center;"><div style="font-weight: normal; text-align: start; font-family: verdana, arial, helvetica, sans-serif; font-size: 13px;"><div class="aplus"></div></div></h1>

Rechercher des sujets similaires à "macro bouton enregistrement csv"