Export automatisé (VBA)

Bonjour,

je recherche un peu d'aide pour automatiser une tâche.

Initial : Je dispose d'un tableau croisé dynamique synthétisant des données qualités de cours d'eau.

Objectif : J'aimerais effectuer un export XLS du tableau de données pour chaque cours d'eau en filtrant la donnée par le nom de chaque rivière.

Je parviens à faire l'export avec un clic bouton mais je dois à chaque fois changer manuellement le nom du cours d'eau puis re-cliquer,etc.

J'aimerais un clic bouton qui exporte le tableau du cours d'eau 1 puis affiche le tableau du cours d'eau 2 l'exporte, puis le cours d'eau 3 etc.

Merci d'avance si quelqu'un parviens à m'aider. J'imagine qu'avec une boucle c'est facilement réalisable mais je bute sur la syntaxe.

Olivier

Bonjour,

un exemple de boucle pour toutes les valeur du champ "test" du TCD "PivotTable1"

    With ActiveSheet.PivotTables("PivotTable1").PivotFields("test")
        For Each pvitem In .PivotItems
            .CurrentPage = pvitem.Value
' faire ce que tu veux faire pour cette valeur du champ "test"
        Next
    End With

Bonjour et merci tout d'abord pour ton aide.

J'ai intégré ces lignes dans mon code mais j'obtiens cette erreur : "Impossible de définir la propriété CurrentPage de la classe PivotField".

Voici mon code :

Sub export_xls()

With ActiveSheet.PivotTables("Tableau croisé dynamique1").PivotFields("StaCode")
        For Each pvitem In .PivotItems
            .CurrentPage = pvitem.Value

Range("A3").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheets("resultat").Select
    Range("A1").Select
    ActiveSheet.Paste
    Sheets("resultat").Copy
    ChDir "Z:\chemin repertoire de sauvegarde"
    ActiveWorkbook.SaveAs Filename:= _
        "Z:\chemin repertoire de sauvegarde\" & Range("A2") & ".xlsx", _
        FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWindow.Close
    Selection.ClearContents
    Sheets("tableau_export").Activate

    Next
   End With

End Sub

Vois-tu mon erreur ? J'ai du mal à décrypter ces messages d'erreur.

Merci d'avance.

Olivier

bonjour,

je pense que malheureusement cette possibilité n'existe qu'à partir de la version office 2010

J'ai justement Office 2010

Olivier

Bonjour,

comme cette boucle fonctionne pour mon cas, l'erreur doit être liée à ton fichier.

vérifie les noms de ton TCD et de ton champ.

sinon peux-tu mettre ton fichier en pièce jointe ?

Salut,

voilà mon fichier.

J'ai dû l'adapter pour l'envoyer ici, du coup j'ai sacrément tronqué ma base mais le principe reste le même. J'ai par contre supprimer le bout de code que j'avais rédigé. Si tu as compris le principe il se réécrit rapidement.

Merci beaucoup si tu parviens à faire fonctionner cette manip.

Bonjour,

je pensais que tu utilisais un filtre au niveau du rapport et non au niveau des lignes, voici le code adapté

Sub export_xls()

With ActiveSheet.PivotTables("Tableau croisé dynamique1").PivotFields("StaCode")
    For Each pvitem In .PivotItems
             pvitem.Visible = True 'sélection d'une valeur
             For Each pvitem1 In .PivotItems
                If pvitem1 <> pvitem Then pvitem1.Visible = False 'déselection de toutes les autres valeurs
             Next
        ' insère ton code ici
    Next
End With

End Sub

Bonjour,

merci c'est top, ça fonctionne très bien. Et j'apprécie les explications qui accompagne ton bout de code.

Penses-tu que je puisse optimiser mon code pour accélérer les exports ?

Sub export_xls()

With ActiveSheet.PivotTables("TCD1").PivotFields("StaCode")
    For Each pvitem In .PivotItems
             pvitem.Visible = True 'sélection d'une valeur
            For Each pvitem1 In .PivotItems
                If pvitem1 <> pvitem Then pvitem1.Visible = False 'déselection de toutes les autres valeurs
            Next

    Range("A3").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheets("resultat").Select
    Range("A1").Select
    ActiveSheet.Paste
    Sheets("resultat").Copy
    ChDir "Z:\chemin de sauvegarde\TABLEAU_RESULTAT_RIVIERE"
    ActiveWorkbook.SaveAs Filename:= _
        "Z:\chemin de sauvegarde\TABLEAU_RESULTAT_RIVIERE\" & Range("A2") & ".xlsx", _
        FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWindow.Close
    Selection.ClearContents
    Sheets("tableau_export").Activate

Next
End With

End Sub

Merci d'avance si tu as une idée. Mais déjà comme ça c'est hyper satisfaisant.

Merci encore.

Olivier

Bonjour,

code adapté (4 x plus rapide chez moi)

Sub export_xls()
Application.ScreenUpdating = False

With Sheets("tableau_export").PivotTables("TCD1").PivotFields("StaCode")
    For Each pvitem In .PivotItems
             pvitem.Visible = True 'sélection d'une valeur
            For Each pvitem1 In .PivotItems
                If pvitem1 <> pvitem Then pvitem1.Visible = False 'déselection de toutes les autres valeurs
            Next
    dc = Sheets("tableau_export").Range("A1").End(xlToRight).Column
    dl = Sheets("tableau_export").Range("A1").End(xlDown).Row
    Sheets("tableau_export").Range("A1", Sheets("tableau_export").Cells(dl, dc)).Copy
    Sheets("resultat").Range("A1").PasteSpecial Paste:=xlPasteValues
    Sheets("resultat").Copy
    ChDir "Z:\chemin de sauvegarde\TABLEAU_RESULTAT_RIVIERE"
    ActiveWorkbook.SaveAs Filename:= _
        "Z:\chemin de sauvegarde\TABLEAU_RESULTAT_RIVIERE\" & Range("A2") & ".xlsx", _
       FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWindow.Close
    Sheets("resultat").Cells.Delete
Next
End With

Application.ScreenUpdating = True
End Sub

Ok merci beaucoup pour ton aide je vais tester tout ça.

Olivier