1. Ce site utilise des "témoins de connexion" (cookies) conformes aux textes de l'Union Européenne. Continuer à naviguer sur nos pages vaut acceptation de notre règlement en la matière. En savoir plus.

XL 2013 Allègement d'une macro

Discussion dans 'Forum Excel' démarrée par Xorys, 7 Octobre 2018.

  1. Xorys

    Xorys XLDnaute Nouveau

    Inscrit depuis le :
    7 Octobre 2018
    Messages :
    20
    "J'aime" reçus :
    0
    Bonjour,

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

    Code (Text):
    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.
     

    Pièces jointes:

    Dernière édition: 7 Octobre 2018
  2. Chargement...

    Discussions similaires - Allègement macro Forum Date
    Allègement du code pour accélération macro Forum Excel 25 Mai 2010
    Allègement & Simplification Macro Forum Excel 19 Novembre 2009
    XL 2016 Allègement code boucle et Aléatoire couleur Forum Excel 23 Février 2018
    Allégement Fichier Forum Excel 27 Octobre 2011
    Modification, allégement d'un classeur Excel Forum Excel 10 Septembre 2011

  3. Xorys

    Xorys XLDnaute Nouveau

    Inscrit depuis le :
    7 Octobre 2018
    Messages :
    20
    "J'aime" reçus :
    0
    Bonjour,

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

    job75 XLDnaute Barbatruc

    Inscrit depuis le :
    15 Mai 2008
    Messages :
    25330
    "J'aime" reçus :
    2090
    Sexe :
    Masculin
    Habite à:
    Paris
    Utilise:
    Excel 2013 (PC)
    Bonjour Xorys,
    Oui, un fichier, pas sorcier de l'anonymiser avec quelques lignes.

    A+
     
  5. Xorys

    Xorys XLDnaute Nouveau

    Inscrit depuis le :
    7 Octobre 2018
    Messages :
    20
    "J'aime" reçus :
    0
    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.
     

    Pièces jointes:

  6. job75

    job75 XLDnaute Barbatruc

    Inscrit depuis le :
    15 Mai 2008
    Messages :
    25330
    "J'aime" reçus :
    2090
    Sexe :
    Masculin
    Habite à:
    Paris
    Utilise:
    Excel 2013 (PC)
    Re,

    Puisque votre but est de filtrer les "OFF" pas besoin de TCD et si vous voulez du VBA :
    Code (Text):
    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+
     

    Pièces jointes:

  7. job75

    job75 XLDnaute Barbatruc

    Inscrit depuis le :
    15 Mai 2008
    Messages :
    25330
    "J'aime" reçus :
    2090
    Sexe :
    Masculin
    Habite à:
    Paris
    Utilise:
    Excel 2013 (PC)
    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+
     
  8. Xorys

    Xorys XLDnaute Nouveau

    Inscrit depuis le :
    7 Octobre 2018
    Messages :
    20
    "J'aime" reçus :
    0
    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".
     
    Dernière édition: 7 Octobre 2018
  9. job75

    job75 XLDnaute Barbatruc

    Inscrit depuis le :
    15 Mai 2008
    Messages :
    25330
    "J'aime" reçus :
    2090
    Sexe :
    Masculin
    Habite à:
    Paris
    Utilise:
    Excel 2013 (PC)
    Bonjour Xorys,
    Vous n'y êtes pas, le nombre de colonnes n'est pas un problème, voyez le fichier joint et la macro modifiée :
    Code (Text):
    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+
     

    Pièces jointes:

  10. Xorys

    Xorys XLDnaute Nouveau

    Inscrit depuis le :
    7 Octobre 2018
    Messages :
    20
    "J'aime" reçus :
    0
    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".
     
  11. Xorys

    Xorys XLDnaute Nouveau

    Inscrit depuis le :
    7 Octobre 2018
    Messages :
    20
    "J'aime" reçus :
    0
    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 :

    Code (Text):

    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.
     

    Pièces jointes:

  12. Xorys

    Xorys XLDnaute Nouveau

    Inscrit depuis le :
    7 Octobre 2018
    Messages :
    20
    "J'aime" reçus :
    0
    Je me permet de relancer le sujet.
     

Partager cette page