Filtre dans Base de données pour extraction fichier CSV

Bonjour à tous,

J'ai une base de données et je souhaite faire des filtres (ca pas de problème), mais je souhaite créer une macro qui crée un fichier.csv du filtre ..Exemple en PJ merci de votre aide

Bonjour,

Copie ce code dans un module standard de ton fichier.

Effectue un filtre puis exécute la procédure.

A te relire.

Cdlt.

Option Explicit
Public Sub Export_en_CSV()
Dim myPath As String, myFile As String
Dim wb As Workbook
Dim ws As Worksheet

    Application.ScreenUpdating = False

    myPath = ActiveWorkbook.Path & Application.PathSeparator

    Set wb = ThisWorkbook
    Set ws = wb.ActiveSheet
    myFile = ws.Name & Format(Now, "ddmmyy hhmm")
    ws.Cells(1, 1).SpecialCells(xlCellTypeVisible).Copy

    Workbooks.Add (xlWBATWorksheet)
    Worksheets(1).Cells(1, 1).PasteSpecial xlPasteValuesAndNumberFormats

    ActiveWorkbook.SaveAs _
            Filename:=myPath & myFile, _
            FileFormat:=xlCSV, _
            CreateBackup:=False, _
            Local:=True
    ActiveWorkbook.Close False

    Set ws = Nothing: Set wb = Nothing

End Sub

Merci Jean Eric,

Dans le fichier Exporté il y'a que la cellule A1 (ENVOI), j'ai besoin d'avoir la base de données filtrées

Ex : J'ai ma bdd qui fait environ 500 lignes, j'effectue des filtres reste 30 lignes, ces 30 lignes je les souhaites dans un fichier CSV...

Merci de ton aide

Re,

Pour ma part, avec un filtre sur 'Conseil général', voici le csv que j'obtiens:

* Le cas que tu évoques se produit si la plage n'est pas filtrée!!!

Ah oui oui pardon,

Juste une chose, ou est ce que je peux choisir dans le code l'emplacement d'enregistrement du fichier?

Merci merci

Re,

Une variante

Option Explicit
Public Sub Export_en_CSV()
Dim myPath As String, myFile As String
Dim wb As Workbook
Dim ws As Worksheet
Dim rng As Range

    Application.ScreenUpdating = False

    myPath = ActiveWorkbook.Path & Application.PathSeparator

    Set wb = ThisWorkbook
    Set ws = wb.ActiveSheet
    myFile = ws.Name & Format(Now, "ddmmyy hhmm")
    Set rng = ws.Cells(1, 1).SpecialCells(xlCellTypeVisible)

    If rng.Address = "$A$1" Then
        ws.Cells(1, 1).CurrentRegion.Copy
    Else
        rng.Copy
    End If

    Workbooks.Add (xlWBATWorksheet)
    Worksheets(1).Cells(1, 1).PasteSpecial xlPasteValuesAndNumberFormats

    ActiveWorkbook.SaveAs _
            Filename:=myPath & myFile, _
            FileFormat:=xlCSV, _
            CreateBackup:=False, _
            Local:=True
    ActiveWorkbook.Close False

    Set rng = Nothing: Set ws = Nothing: Set wb = Nothing

End Sub

Daccord

Par contre, est-ce que je peux choisir l'emplacement et le nom de fichier ?

Re,

Nouvelle variante avec le choix du dossier.

A tester.

Cdlt.

Option Explicit
Public Sub Export_2()
Dim wb As Workbook
Dim ws As Worksheet
Dim strInitialFilename As String
Dim rng As Range
Dim myFile

    Application.ScreenUpdating = False

    Set wb = ThisWorkbook
    Set ws = wb.ActiveSheet
    strInitialFilename = ws.Name & Format(Now, "ddmmyy hhmm")
    Set rng = ws.Cells(1, 1).SpecialCells(xlCellTypeVisible)

    If rng.Address = "$A$1" Then
        ws.Cells(1, 1).CurrentRegion.Copy
    Else
        rng.Copy
    End If

    Workbooks.Add (xlWBATWorksheet)
    Worksheets(1).Cells(1, 1).PasteSpecial xlPasteValuesAndNumberFormats
    Application.CutCopyMode = 0

    myFile = Application.GetSaveAsFilename _
             (InitialFileName:=strInitialFilename, _
              filefilter:="Fichiers csv (*.csv),*.csv", _
              Title:="Enregistrer fichier csv")

    If myFile = False Then
        ActiveWorkbook.Close False
        Exit Sub
    End If

    ActiveWorkbook.SaveAs myFile

    Set rng = Nothing: Set ws = Nothing: Set wb = Nothing

End Sub

Apparement cela fonctionne....Merci beaucoup Jean Marc

Bonjour, bonjour !

Le premier code ne passant pas non plus de mon côté, voici une variante simplifiée :

Sub Demo()
    Application.ScreenUpdating = False
       FICHIER = Application.GetSaveAsFilename("Export .csv", "Fichiers texte, *.csv")
    If FICHIER = False Then Beep: Exit Sub

    With Workbooks.Add(xlWBATWorksheet)
        ThisWorkbook.Worksheets(1).Cells(1).CurrentRegion.SpecialCells(xlCellTypeVisible).Copy .ActiveSheet.Cells(1)
        Application.DisplayAlerts = False
        .SaveAs FICHIER, xlCSV, Local:=True
        Application.DisplayAlerts = True
        .Close False
    End With
End Sub

Bonjour,

En faite cela serait plus simple que je puisse extraire dans un fichier .csv les données dont les cellules sont en vert...

Pouvez -vous m'aider?

Sans logique, je reste avec le code de mon précédent post - resté sans retour - fonctionnant bien avec les filtres …

Cela fonctionnait bien avec votre code. je l'ai validé un message plutot....

Cela marche nickel...mais il est plus facile pour moi de mettre en couleur les cellules que je dois extraire...

En résumé je souhaite extraire dans un fichier .csv uniquement les cellules en verte avec les en tête de colonne...

Merci merci

Regarder dans l'aide VBA dans les options des filtres pour la couleur …

Je crois que cela a été implémenté depuis la version 2007 et comme là je suis sous une version 2003 …

J'ai vu un exemple dans un sujet récent.

Un exemple dans le sujet Filtre couleur sur plusieurs colonne …

Normalement il n'y rien à modifier dans mon code vu qu'il intervient post filtre !

Sinon sans utiliser de filtre couleur :

Sub Macro1()
     Const SEP = ";"
       FICHIER = Application.GetSaveAsFilename("Export .csv", "Fichiers texte, *.csv")
    If FICHIER <> False Then
        With Feuil1.Cells(1).CurrentRegion
            S$ = Join(Application.Index(.Value, 1), SEP)

            For R& = 2 To .Rows.Count
                If .Cells(R, 4).Interior.ColorIndex <> xlNone Then
                    S = S & vbNewLine & Join(Application.Index(.Value, R), SEP)
                End If
            Next
        End With
                                    FF% = FreeFile
        Open FICHIER For Output As #FF
                             Print #FF, S;
                             Close #FF
    End If
End Sub

Bonjour,

Merci pour votre réponse, mais quand je lance la macro il y'a une erreur...

Et de mon côté aucun souci …

Avez-vous une solution ?

Bonjour,

Est ce que quelqu’un peut m'aidé je ne trouve pas de solution...

Merci beaucoup