Macro filtre TCD

Le 17/11/2016 à 11:13

Bonjour

J'ai une feuille de données que j'exploite avec un TCD pour plus de clarté.

J'ai besoin de copier la feuille du TCD dans une nouvelle feuille, ce pour chaque choix de la liste déroulante du filtre du TCD.

La macro que j'ai faite interroge la liste par les noms inscrit dans la liste du filtre.

Mais toute modification de la liste m'obligera à compléter la macro.

Existe t'il un moyen d'interroger toute la liste d'un coup sans limite du nombre de choix, et sans utiliser les noms inscrit dans cette liste?

Sub test_exploit()
'
' Test_exploit
'

'
'selectionne_le_tableau_croisé
    Sheets("tableau croisé").Select
'actualise_le_TCD
ActiveSheet.PivotTables("Tableau croisé").PivotCache.Refresh
'Selectionne_un_nom_dans_le_filtre_TCD
ActiveSheet.PivotTables("Tableau croisé").PivotFields("Tâches").CurrentPage = _
        "Circulation sur site"
'Copie_la_feuille
Cells.Copy
'crée_une_nouvelle_feuille
Sheets.Add After:=ActiveSheet
'colle_dans_la_nouvelle_feuille
ActiveSheet.Paste
'nomme_la_feuille_selon_la_cellule_B1
ActiveSheet.Name = Range("B1").Value
 'et_ca_recommence_pour_tous_les_choix_du_filtre_
 Sheets("tableau croisé").Select
   ActiveSheet.PivotTables("Tableau croisé").PivotCache.Refresh
    ActiveSheet.PivotTables("Tableau croisé").PivotFields("Tâches").CurrentPage = _
        "Analyses en laboratoire"
    Cells.Copy
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Paste
    ActiveSheet.Name = Range("B1").Value
    Sheets("tableau croisé").Select
   ActiveSheet.PivotTables("Tableau croisé").PivotCache.Refresh
    ActiveSheet.PivotTables("Tableau croisé").PivotFields("Tâches").CurrentPage = _
        "Prélèvement CET"
    Cells.Copy
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Paste
    ActiveSheet.Name = Range("B1").Value
     Sheets("tableau croisé").Select
   ActiveSheet.PivotTables("Tableau croisé").PivotCache.Refresh
    ActiveSheet.PivotTables("Tableau croisé").PivotFields("Tâches").CurrentPage = _
        "Prélèvements fontaines"
    Cells.Copy
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Paste
    ActiveSheet.Name = Range("B1").Value
     Sheets("tableau croisé").Select
   ActiveSheet.PivotTables("Tableau croisé").PivotCache.Refresh
    ActiveSheet.PivotTables("Tableau croisé").PivotFields("Tâches").CurrentPage = _
        "Pollution des eaux"
    Cells.Copy
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Paste
    ActiveSheet.Name = Range("B1").Value
     Sheets("tableau croisé").Select
   ActiveSheet.PivotTables("Tableau croisé").PivotCache.Refresh
    ActiveSheet.PivotTables("Tableau croisé").PivotFields("Tâches").CurrentPage = _
        "Prélèvements ZI"
    Cells.Copy
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Paste
    ActiveSheet.Name = Range("B1").Value
     Sheets("tableau croisé").Select
   ActiveSheet.PivotTables("Tableau croisé").PivotCache.Refresh
    ActiveSheet.PivotTables("Tableau croisé").PivotFields("Tâches").CurrentPage = _
        "Prélèvements STEP"
    Cells.Copy
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Paste
    ActiveSheet.Name = Range("B1").Value
     Sheets("tableau croisé").Select
   ActiveSheet.PivotTables("Tableau croisé").PivotCache.Refresh
    ActiveSheet.PivotTables("Tableau croisé").PivotFields("Tâches").CurrentPage = _
        "Traitement des blattes"
    Cells.Copy
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Paste
    ActiveSheet.Name = Range("B1").Value
     Sheets("tableau croisé").Select
   ActiveSheet.PivotTables("Tableau croisé").PivotCache.Refresh
    ActiveSheet.PivotTables("Tableau croisé").PivotFields("Tâches").CurrentPage = _
        "Prélèvements eaux douces"
    Cells.Copy
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Paste
    ActiveSheet.Name = Range("B1").Value
     Sheets("tableau croisé").Select
   ActiveSheet.PivotTables("Tableau croisé").PivotCache.Refresh
    ActiveSheet.PivotTables("Tableau croisé").PivotFields("Tâches").CurrentPage = _
        "Dératisation"
    Cells.Copy
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Paste
    ActiveSheet.Name = Range("B1").Value
     Sheets("tableau croisé").Select
   ActiveSheet.PivotTables("Tableau croisé").PivotCache.Refresh
    ActiveSheet.PivotTables("Tableau croisé").PivotFields("Tâches").CurrentPage = _
        "Déplacement routier"
    Cells.Copy
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Paste
    ActiveSheet.Name = Range("B1").Value
     Sheets("tableau croisé").Select
   ActiveSheet.PivotTables("Tableau croisé").PivotCache.Refresh
    ActiveSheet.PivotTables("Tableau croisé").PivotFields("Tâches").CurrentPage = _
        "Tâches administratives"
    Cells.Copy
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Paste
    ActiveSheet.Name = Range("B1").Value
    End Sub

Je vous remercie par avance.

PS: m'initiant seul depuis 48h aux macros,vous n'êtes pas à l'abri de question complémentaires bêtes de ma part sur vos explications.

Le 17/11/2016 à 11:23

Bonjour,

Merci de joindre un fichier pour une réponse adaptée.

Cdlt.

Le 17/11/2016 à 11:35

Voici le fichier

La macro en question est test exploit

13risque-solution-mise-en-place-macro.xlsm (82.64 Ko)
Le 17/11/2016 à 12:47

Re,

Une proposition à étudier.

Ci-dessous la procédure principale.

Cdlt.

29risque-solution-mise-en-place-macro.xlsm (101.11 Ko)
Option Explicit
Option Private Module

Public Sub CreateWorksheets()
Dim ws As Worksheet
Dim pt As PivotTable
Dim pf As PivotField
Dim pi As PivotItem
Dim strPF As String, strPI As String

    On Error GoTo err_Handler
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    strPF = "Tâches"
    Set ws = ActiveWorkbook.Worksheets("tableau croisé")
    Set pt = ws.PivotTables(1)
    Set pf = pt.PivotFields(strPF)

    For Each pi In pf.PivotItems
        strPI = Left("e_" & pi.Name, 31)
        On Error Resume Next
        Worksheets(strPI).Delete
        On Error GoTo 0
        ws.Copy After:=Worksheets(Worksheets.Count)
        With ActiveSheet
            .Name = strPI
            With .PivotTables(1).PivotFields(strPF)
                .PivotItems(pi.Name).Visible = True
                .CurrentPage = pi.Name
            End With
        End With
    Next pi

   ws.Activate

exit_Handler:
    Application.DisplayAlerts = True
    Exit Sub
err_Handler:
    MsgBox "Erreur : " & Err.Number & vbCrLf & Err.Description
    Resume exit_Handler

End Sub
Le 17/11/2016 à 13:43

Merci Jean Eric

Ça marche impeccablement, même si j'y comprends rien.

Aurais tu un livre à me conseiller pour qu'un novice apprenne les rudiments de vba?

Les tutoriels internet me sont un peu rébarbatifs et peu compréhensibles. (pour le grand novice que je suis)

Le 18/11/2016 à 13:45

Bonjour,

Ce site te propose des cours Excel et des cours VBA.

Prends le temps de les consulter.

Cordialement.

Le 22/11/2016 à 11:07

Bonjour,

Je reviens sur cette macro, elle fonctionne parfaitement, j'ai testé en ajoutant une nouvelle tâche dans la feuille DU.

La macro me génère une nouvelle feuille.

Par contre quand je retire cette tâche, et que j'actualise tout le classeur, elle devrait disparaître.

Malheureusement une feuille se génère encore avec les informations du TCD filtre:analyses en laboratoire.

Et j'ai une seconde question concernant un terme de la macro: à quoi renvoie le 31?

Est ce le nombre de caractère autorisé pour la chaîne?

For Each pi In pf.PivotItems
            strPI = Left("e_" & pi.Name, 31)
            On Error Resume Next
            Worksheets(strPI).Delete
Le 23/11/2016 à 13:06

Bonjour,

Modifie la procédure comme ci-dessous (partie surlignée).

Cdlt.

Option Explicit
Option Private Module

Public Sub CreateWorksheets()
Dim ws As Worksheet
Dim pt As PivotTable
Dim pf As PivotField
Dim pi As PivotItem
Dim strPF As String, strPI As String

    On Error GoTo err_Handler
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    strPF = "Tâches"
    Set ws = ActiveWorkbook.Worksheets("tableau croisé")
    Set pt = ws.PivotTables(1)
    Set pf = pt.PivotFields(strPF)

    With pt.PivotCache
        .MissingItemsLimit = xlMissingItemsNone
        .Refresh
    End With

    For Each pi In pf.PivotItems
        strPI = Left("e_" & pi.Name, 31)
        On Error Resume Next
        Worksheets(strPI).Delete
        On Error GoTo 0
        ws.Copy After:=Worksheets(Worksheets.Count)
        With ActiveSheet
            .Name = strPI
            With .PivotTables(1).PivotFields(strPF)
                .PivotItems(pi.Name).Visible = True
                .CurrentPage = pi.Name
            End With
        End With
    Next pi

    ws.Activate

exit_Handler:
    Application.DisplayAlerts = True
    Exit Sub
err_Handler:
    MsgBox "Erreur : " & Err.Number & vbCrLf & Err.Description
    Resume exit_Handler

End Sub
Le 23/11/2016 à 15:23

Bonjour Jean Eric.

Un grand merci à toi.

Rechercher des sujets similaires à "macro filtre tcd"