XL 2013 Allègement d'une macro

[Xorys]

Bonjour,

J'utilise le code suivant pour des filtres de tableau croisé dynamique :

Option Explicit
Option Base 1

Sub Configuration()

  Dim pivitemName As PivotItem, i As Integer
  Dim aUsersArray() As String, intPos As Integer

  On Error Resume Next
  ReDim aUsersArray(118)
  i = 1
  Sheets("Config").Activate
  Cells(1, 1).Select
  Do While Not IsEmpty(ActiveCell.Value)
    aUsersArray(i) = ActiveCell.Value
    i = i + 1
    ActiveCell.Offset(1, 0).Select
  Loop

  Sheets("TCD").Activate
  For Each pivitemName In ActiveSheet.PivotTables("TCD1").PivotFields("Etat").PivotItems
    intPos = SearchValueInArrayByPosition(aUsersArray, pivitemName.Value)
    If intPos = 0 Then
      pivitemName.Visible = False
    Else
      pivitemName.Visible = True
    End If
  Next
On Error Resume Next
  ReDim aUsersArray(20)
  i = 1
  Sheets("Config").Activate
  Cells(1, 2).Select
  Do While Not IsEmpty(ActiveCell.Value)
    aUsersArray(i) = ActiveCell.Value
    i = i + 1
    ActiveCell.Offset(1, 0).Select
  Loop

  Sheets("TCD").Activate
  For Each pivitemName In ActiveSheet.PivotTables("TCD2").PivotFields("Assigné").PivotItems
    intPos = SearchValueInArrayByPosition(aUsersArray, pivitemName.Value)
    If intPos = 0 Then
      pivitemName.Visible = False
    Else
      pivitemName.Visible = True
    End If
  Next

End Sub

Function SearchValueInArrayByPosition(aArray, varValue) As Variant
  Dim varPos As Variant, i As Integer

  varPos = Application.Match(varValue, aArray, 0)
  If IsError(varPos) Then
    SearchValueInArrayByPosition = 0
  Else
    SearchValueInArrayByPosition = varPos
  End If

End Function

Ce code me permet d'appliquer automatique un filtre dans mes 2 tableaux croisés dynamiques à partir d'une liste de choix dans la feuille "Config".
Ce code fonctionne parfaitement mais je l'ai récupéré sur un site et je pense qu'il peut être allégé.

Est-ce que vous pourriez y jeter un œil, en vous remerciant.

 

[Xorys]

Bonjour,

Je me permet de relancer le sujet, est-ce qu'il vous faut des informations supplémentaires ?

 

[job75]

Bonjour Xorys,

Je me permet de relancer le sujet, est-ce qu'il vous faut des informations supplémentaires ?

Oui, un fichier, pas sorcier de l'anonymiser avec quelques lignes.

A+

 

[Xorys]

Je viens d'ajouter un fichier pour exprimer mon besoin.
J'ai très largement simplifié ce fichier, d'origine j'ai beaucoup plus de colonne dans l'onglet "Data" et donc plus de filtrer sur les tableaux croisés dynamique.

Merci.

 

[job75]

Re,

Puisque votre but est de filtrer les "OFF" pas besoin de TCD et si vous voulez du VBA :

Private Sub Worksheet_Activate()
Dim t, d As Object, i&, e, p%
t = Sheets("Data").ListObjects(1).Range
Set d = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(t)
    If UCase(t(i, 1)) Like "OFF*" Then d(t(i, 1) & Chr(1) & t(i, 2)) = ""
Next
i = 0
If d.Count Then
    ReDim t(1 To d.Count, 1 To 2)
    For Each e In d.keys
        i = i + 1
        p = InStr(e, Chr(1))
        t(i, 1) = Left(e, p - 1)
        t(i, 2) = Mid(e, p + 1)
    Next
    If FilterMode Then ShowAllData 'si la feuille est filtrée
    [A2].Resize(i, 2) = t 'restitution
End If
Range("A" & i + 2 & ":B" & Rows.Count).ClearContents 'RAZ sous le tableau
With UsedRange: End With 'actualise la barre de défilement verticale
End Sub

A placer dans le code de la feuille "Filtrer OFF", la macro se déclenche quand on active la feuille.

Fichier (2).

A+

 

[job75]

Re,

Pour ceux qui ne l'auraient pas vu le tableau de la feuille "Data" comporte 20 000 lignes.

Il est intéressant de comparer les durées d'exécution/recalcul :

- solution par formule de la feuille "Config" => 0,38 seconde

- solution VBA de la feuille "Filtrer OFF" => 0,02 seconde...

A+

 

[Xorys]

Bonjour,

Je vous remercie de votre aide.

Effectivement la feuille "Data" fait 20 000 lignes car c'est ici que je met mes extractions. Sur le fichier il y a que 2 colonnes mais sur l'original j'en ai environ une dizaine.
C'est pourquoi j'ai réellement besoin de tableaux croisés dynamiques pour ensuite sortir les informations dont j'ai besoin.

Mais étant donné que je suis amené à régulièrement changer mes données dans "Data" (je sélectionne tout, je supprime et je copie mes nouvelles données), je perds systématiquement mes filtres dans mes tableaux. C'est pourquoi je souhaite avec une macro appliquer des filtres par rapport à une liste de choix que j'ai défini dans la feuille "Config".

 

[job75]

Bonjour Xorys,

Sur le fichier il y a que 2 colonnes mais sur l'original j'en ai environ une dizaine.
C'est pourquoi j'ai réellement besoin de tableaux croisés dynamiques pour ensuite sortir les informations dont j'ai besoin.

Vous n'y êtes pas, le nombre de colonnes n'est pas un problème, voyez le fichier joint et la macro modifiée :

Private Sub Worksheet_Activate()
Dim t, ncol%, d As Object, i&, x$, resu(), e, n&, j%
t = Sheets("Data").ListObjects(1).Range
ncol = UBound(t, 2)
Set d = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(t)
    If UCase(t(i, 1)) Like "OFF*" Then
        x = t(i, 1) & Chr(1) & t(i, 2)
        If Not d.exists(x) Then d(x) = i 'mémorise le numéro de ligne
    End If
Next
If d.Count Then
    ReDim resu(1 To d.Count, 1 To ncol)
    For Each e In d.keys
        n = n + 1
        i = d(e)
        For j = 1 To ncol
            resu(n, j) = t(i, j)
        Next
    Next
    If FilterMode Then ShowAllData 'si la feuille est filtrée
    [A2].Resize(n, ncol) = resu 'restitution
End If
[A2].Offset(n).Resize(Rows.Count - n - 1, ncol).ClearContents 'RAZ sous le tableau
With UsedRange: End With 'actualise la barre de défilement verticale
End Sub

Durée d'exécution => 0,04 seconde.

Recalcul de la feuille "Config" => 1,85 seconde.

A+

 

[Xorys]

Je vais regarder, merci.

Quand je parlais de plusieurs colonne, c'était pour justifier la nécessité d'un tableau croisé dynamique et mon besoin d'appliquer des filtres via une liste de choix définie sur une autre feuille. Car je remplace régulièrement mes données dans la feuille "Data" ce qui fait que les filtres de mon tableau sont à refaire à chaque fois.
Dans un précédent message, tu disais que je n'avais pas besoin d'un tableau croisé dynamique vu que je souhaitait juste filtrer les "OFF".

 

[Xorys]

Je vous met mon fichier avec plus d'information pour que mieux faire comprendre mon besoin.

Dans la feuille "Data" je met mes extractions, régulièrement j'efface la feuille et recopie de nouvelles données.
Dans la feuille "Paramètre", via des commandes que vous m'avez fourni, je récupère certaines informations de la feuille "Data".

La macro que je souhaite alléger mais qui remplie déjà son rôle entre en action maintenant :

Option Explicit
Option Base 1

Sub Configuration()

  Dim pivitemName As PivotItem, i As Integer
  Dim aUsersArray() As String, intPos As Integer

  On Error Resume Next
  ReDim aUsersArray(200)
  i = 1
  Sheets("Paramètre").Activate
  Cells(1, 1).Select
  Do While Not IsEmpty(ActiveCell.Value)
    aUsersArray(i) = ActiveCell.Value
    i = i + 1
    ActiveCell.Offset(1, 0).Select
  Loop

  Sheets("TCD").Activate
  For Each pivitemName In ActiveSheet.PivotTables("TCD1").PivotFields("Description").PivotItems
    intPos = SearchValueInArrayByPosition(aUsersArray, pivitemName.Value)
    If intPos = 0 Then
      pivitemName.Visible = False
    Else
      pivitemName.Visible = True
    End If
  Next
On Error Resume Next
  ReDim aUsersArray(200)
  i = 1
  Sheets("Paramètre").Activate
  Cells(1, 3).Select
  Do While Not IsEmpty(ActiveCell.Value)
    aUsersArray(i) = ActiveCell.Value
    i = i + 1
    ActiveCell.Offset(1, 0).Select
  Loop

  Sheets("TCD").Activate
  For Each pivitemName In ActiveSheet.PivotTables("TCD1").PivotFields("Local").PivotItems
    intPos = SearchValueInArrayByPosition(aUsersArray, pivitemName.Value)
    If intPos = 0 Then
      pivitemName.Visible = False
    Else
      pivitemName.Visible = True
    End If
  Next

End Sub

Function SearchValueInArrayByPosition(aArray, varValue) As Variant
  Dim varPos As Variant, i As Integer

  varPos = Application.Match(varValue, aArray, 0)
  If IsError(varPos) Then
    SearchValueInArrayByPosition = 0
  Else
    SearchValueInArrayByPosition = varPos
  End If

End Function

Dans la feuille "TCD" je dois appliquer 2 filtres à mon tableau croisé dynamique : "Description" et "Local".
Pour les appliquer la macro filtre en fonctions des informations dans la feuille "Paramètre" :
Onglet "Data1" pour le filtre "Description".
Onglet "Data2" pour le filtre "Local".

Sans cette macro, quand je remplace mes extractions dans la feuille Data, tous mes filtres sont à refaire dans mon tableau croisé dynamique car il y a des informations dans description et local qui peuvent changer.

 

[Xorys]

Je me permet de relancer le sujet.