EXCEL :: TCD :: SEGMENTS :: Identifier l'élément sélectionné dans le segment :: Modifier dynamiquement la valeur d'un segment :: VBA

[oguruma]

Bonjour le Forum,

Afin de mieux documenter les TCD qui comportent des segments il peut être confortable d'afficher l'élément sélectionné dans le segment ou dans certains cas il peut être nécessaire d'intervenir dynamiquement sur la valeur à affecter au segment. Je vous présente une façon d'y parvenir. Si les membres chevronnés du Forum ont d'autres solutions je suis preneur, merci 🙂.

1. Identifier l'élément sélectionné dans le segment
Cette méthode est certainement connue par un bon nombre de membres du Forum mais autant le rappeler pour les nouveaux venus.

Les éléments sélectionnés sont ESPAGNE pour le segement PAYS_ORIGINE et IMPORT pour le segment ETAT_PRODUCTION.

On les retrouve donc sous cette forme et les récupérer pour les afficher sous cette forme

Comment y parvenir ?
Dans un "coin caché" du classeur on construit un TCD comportant comme seule et unique colonne le champ du segment comme ceci

La cellule "TOUS" en colonne contient donc la formule qui va identifier la valeur du segment sélectionné. Bien entendu le segment

doit être rattaché au TCD

==> le TCD N°2

La valeur sélectionnée est déterminée par la formule : =SI(NBVAL(M5:M6)>1;"TOUS";M5) qui s'explique assez facilement.

2. Modifier dynamiquement la valeur d'un segment (en d'autres termes intervenir sur un segment)
Pour diverses raisons donc, il peut être nécessaire de piloter les sélections dans le segment en fonction de certains événements ou besoins contextuels du classeur selon les données traitées.

Deux méthodes pour y parvenir avec deux variantes pour chacune.

Méthode 1

On va construire une liste de valeurs dans une cellule. La liste doit correspondre aux éléments du segment.

Puis modifier la valeur du segment on fera appel à une MACRO en VBA

:: Modification d'un élément dans ETAT PROD ::

Sub MODIFIER_SEGMENT_ETAT(Optional hParam As String)
    
    Dim sChoix As String
    
    If hParam = "" Then sChoix = Range("CHOIX_ETAT").Value Else sChoix = Range(hParam).Value

    If sChoix = "IMPORT" Then
        With ActiveWorkbook.SlicerCaches("Segment_ETAT_PRODUCTION")
            .SlicerItems("IMPORT").Selected = True
            .SlicerItems("LOCAL").Selected = False
        End With
    End If
    
    If sChoix = "LOCAL" Then
        With ActiveWorkbook.SlicerCaches("Segment_ETAT_PRODUCTION")
            .SlicerItems("LOCAL").Selected = True
            .SlicerItems("IMPORT").Selected = False
        End With
    End If
    
    If sChoix = "TOUS" Then
        ActiveWorkbook.SlicerCaches("Segment_ETAT_PRODUCTION").ClearManualFilter
    End If

End Sub

Optional hParam As String ==> sera utilisé pour la méthode 2 afin de ne pas dupliquer le code
Ici c'est assez simple car le segment ne comporte que deux valeurs. Il suffit donc de les alterner en fonction de la valeur demandée dans la liste de choix.
On gère également où on ne positionne pas de filtres avec la valeur TOUS sélectionnée. La valeur sélectionnée doit être positionnée à TRUE en 1ère instance.

Pour activer la modification on actionne la macro par le bouton

:: Modification d'un élément dans PAYS_ORIGINE :: (un segment comportant plus de 2 éléments)

En revanche cela peut se compliquer si le segment comporte plusieurs valeurs. Là ici pour 4 valeurs on pourrait encore appliquer la méthode ci-dessus.
Voici donc une manière de gérer dynamiquement les modifications dans un segment quelque soit le nombre d'éléments.

Sub MODIFIER_SEGMENT_PAYS(Optional hParam As String)
    
    Dim vItem As Variant
    Dim sChoix As String
    
    If hParam = "" Then sChoix = Range("CHOIX_PAYS").Value Else sChoix = Range(hParam).Value
    
    If sChoix <> "TOUS" Then
        With ActiveWorkbook.SlicerCaches("Segment_PAYS_ORIGINE")
            .SlicerItems(sChoix).Selected = True
            For Each vItem In .SlicerItems
                If vItem.Name <> sChoix Then vItem.Selected = False
            Next
        End With
    Else
        ActiveWorkbook.SlicerCaches("Segment_PAYS_ORIGINE").ClearManualFilter
    End If
    
End Sub

En premier lieu on affecter la valeur TRUE à l'élément recherché puis on affecter FALSE aux autres. Pour y parvenir on va boucler sur les items du segment en prenant de ne pas mettre à FALSE la valeur sélectionnée. Dans le cas contraire on considère que l'on désactive tous les filtres. Puis on fait appel au bouton pour mettre à jour le segment :

Méthode 2

On va tout simplement se passer des deux boutons macro en faisant appel aux procédures événementielles de la feuille

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Application.Intersect(Target, Range("CHOIX_ETAT2")) Is Nothing Then
        Call MODIFIER_SEGMENT_ETAT("CHOIX_ETAT2")
    End If
    
    If Not Application.Intersect(Target, Range("CHOIX_PAYS2")) Is Nothing Then
        Call MODIFIER_SEGMENT_PAYS("CHOIX_PAYS2")
    End If
End Sub

Call MODIFIER_SEGMENT_ETAT("CHOIX_ETAT2") :==> c'est là qu'intervient le paramètre afin de ne pas dupliquer le code pour l'exemple démontré. Pour votre utilisation cela ne sera peut-être pas nécessaire.

::-:: SYNTHESE ::-::

 

[oguruma]

Re-Bonjour,
Pour faire suite à la 1ère partie présentée hier nous pouvons piloter les filtres du TCD en VBA ce qui peut être pratique dans certains cas et s'affranchir des contraintes des FILTRES spécifiques aux TCD. Nous avons aussi la main sur le design par exemple et dans les choix de valeurs possibles.

Avant d'aller plus loin la modification des éléments d'un segment peut être gérée par une fonction spécifique comme suit :

Appel de la fonction via les procédures événementielles de la feuille

    If Not Application.Intersect(Target, Range("CHOIX_ETAT3")) Is Nothing Then
        Call MODIFIER_SEGMENT("Segment_ETAT_PRODUCTION", "CHOIX_ETAT3", "TOUS")

    End If
    
    If Not Application.Intersect(Target, Range("CHOIX_PAYS3")) Is Nothing Then
        Call MODIFIER_SEGMENT("Segment_PAYS_ORIGINE", "CHOIX_PAYS3")
    End If

Sub MODIFIER_SEGMENT(hSegment As String, hParam As String, Optional hTous As String)

    Dim vItem As Variant
    Dim sChoix As String
    Dim sTous As String
    
    On Error GoTo HANDLE_ERROR
    
    Set oSpeed = New SpeedMacro
    
    oSpeed.SpeedMacroOn
    
    If hTous = "" Then sTous = "TOUS" Else sTous = hTous
    
    If hParam = "" Then
        MsgBox "Veuillez préciser la valeur recherchée dans le segment", vbCritical, "Segment dynamique"
        Exit Sub
    Else
        sChoix = Range(hParam).Value
    End If
        
    If sChoix <> sTous Then
        If Not exists_VALEUR_SEGMENT(hSegment, hParam) Then
            MsgBox "La valeur recherchée n'est pas connue dans le segment", vbCritical, "Segment dynamique"
            Exit Sub
        End If
        With ActiveWorkbook.SlicerCaches(hSegment)
            .SlicerItems(sChoix).Selected = True
            For Each vItem In .SlicerItems
                If vItem.Name <> sChoix Then vItem.Selected = False
            Next
        End With
    Else
        ActiveWorkbook.SlicerCaches(hSegment).ClearManualFilter
    End If

FIN:
    oSpeed.SpeedMacroOff
    Exit Sub
    
HANDLE_ERROR:
    MsgBox "Recherche impossible. Erreur #" & Err.Number & " - " & Err.Description, vbCritical, "Segment dynamique"
    Resume FIN
End Sub

Pour éviter les erreurs de traitement il est prudent de vérifier la présence de l'élément

Function exists_VALEUR_SEGMENT(hSegment As String, hItem As String) As Boolean
    Dim vItem As Variant
    Dim sVal As String
    
    sVal = Range(hItem).Value
    exists_VALEUR_SEGMENT = False
    With ActiveWorkbook.SlicerCaches(hSegment)
        For Each vItem In .SlicerItems
            If vItem.Name = sVal Then
                exists_VALEUR_SEGMENT = True
                Exit Function
            End If
        Next
    End With
End Function

Si la valeur n'est pas présente dans le segment

A l'image des segments on peut donc aussi intervenir dans les filtres du TCD comme ceci

Une nouvelle fois on fait appel aux procédures événementielles

    If Not Application.Intersect(Target, Range("CHOIX_ETAT4")) Is Nothing Then
        Call MODIFIER_SEGMENT("Segment_ETAT_PRODUCTION", "CHOIX_ETAT4", "TOUS")

    End If
    
    If Not Application.Intersect(Target, Range("CHOIX_PAYS4")) Is Nothing Then
        Call ACTIVER_PIVOT_FIELD("Tableau croisé dynamique1", "PAYS_ORIGINE", "CHOIX_PAYS4")
    End If
    
    If Not Application.Intersect(Target, Range("CHOIX_PRODUIT")) Is Nothing Then
        Call ACTIVER_PIVOT_FIELD("Tableau croisé dynamique1", "Produit", "CHOIX_PRODUIT")
    End If
    
    If Not Application.Intersect(Target, Range("CHOIX_CATEGORIE")) Is Nothing Then
        Call ACTIVER_PIVOT_FIELD("Tableau croisé dynamique1", "CATEGORIE", "CHOIX_CATEGORIE")
    End If

Sub ACTIVER_PIVOT_FIELD(hPivotTable As String, hPivotField As String, hItem As String, Optional hTous As String)
    Dim vItem As PivotItem
    Dim sVal As String
    Dim sTous As String
    
    Set oSpeed = New SpeedMacro
    
    oSpeed.SpeedMacroOn
    
    sVal = Range(hItem).Value
    If hTous = "" Then sTous = "TOUS" Else sTous = Range(hTous).Value
    
    If sVal = sTous Then
        With ActiveSheet.PivotTables(hPivotTable).PivotFields(hPivotField)
            For Each vItem In .PivotItems
                 vItem.Visible = True
            Next
        End With
    Else
        With ActiveSheet.PivotTables(hPivotTable).PivotFields(hPivotField)
           If Not exists_VALEUR_PIVOT_TABLES(hPivotTable, hPivotField, hItem) Then
                MsgBox "La valeur recherchée n'est pas connue dans le TCD", vbCritical, "Segment dynamique"
                Exit Sub
           End If
           .PivotItems(sVal).Visible = True
           For Each vItem In .PivotItems
               If vItem.Name <> sVal Then
                  vItem.Visible = False
               End If
            Next
        End With
    End If
    
FIN:
    oSpeed.SpeedMacroOff
    Exit Sub

End Sub

On teste également la présence de la valeur recherchée dans le TCD

Function exists_VALEUR_PIVOT_TABLES(hPivotTable As String, hPivotField As String, hItem As String) As Boolean
    Dim vItem As Variant
    Dim sVal As String
    
    sVal = Range(hItem).Value
    exists_VALEUR_PIVOT_TABLES = False
    
    With ActiveSheet.PivotTables(hPivotTable).PivotFields(hPivotField)
        For Each vItem In .PivotItems
            If vItem.Name = sVal Then
                exists_VALEUR_PIVOT_TABLES = True
                Exit Function
            End If
        Next
    End With
    
End Function

Le code s'appuie sur des listes

Pour tous les éléments d'une liste l'item par défaut est "TOUS" (voir dans le code) et cette valeur peut être ajoutée comme suit
=ASSEMB.V(UNIQUE(TB_STOCK[ELEMENT]);"TOUS")
On concatène "TOUS" au résultat de la fonction UNIQUE

Construction de la liste déroulante de valeurs

Ici on utilise l'adressage étendu via le symbole # dans l'adresse de cellule.

En cas de valeur inconnue

Bonus
Liste des valeurs dans un TCD si besoin pour un traitement annexe

Sub TEST_list_VALEUR_PIVOT_TABLES()
    Call list_VALEUR_PIVOT_TABLES("Tableau croisé dynamique1", "Produit")
End Sub
Sub list_VALEUR_PIVOT_TABLES(hPivotTable As String, hPivotField As String)
    Dim vItem As PivotItem
    Dim sVal As String
    
    With ActiveSheet.PivotTables(hPivotTable).PivotFields(hPivotField)
        For Each vItem In .PivotItems
            Debug.Print vItem.Name
        Next
    End With
End Sub

Pour accélérer les traitements on fait appel à

Si le champ n'est pas implémenté dans le TCD, celui-ci par exemple

Le message d'erreur est renvoyé

En synthèse voici comment cela se traduit dans la conception du TCD et le résultat obtenu