Existe-t-il une macro pour filtrer un tableau par certains éléments de liste ?

Même s'il s'agit d'un ancien article, je vous propose une façon de procéder, à titre de référence.

• Créez un nouveau UserForm avec le nom par défaut "UserForm1".
• Créez une nouvelle ComboBox avec le nom par défaut "ComboBox1" sur le formulaire, comme ceci

Ajoutez ce code au module VBA du formulaire :

Option Explicit

Private enableEvts As Boolean
Private thisCol As Range

Private Sub ComboBox1_Change()
   If enableEvts Then filterColumn thisCol, ComboBox1.Text
   'Me.Hide
End Sub

Public Sub setupList(ByRef col As Range)
   Set thisCol = col
   enableEvts = False
      setList col, ComboBox1
   enableEvts = True
   Me.Caption = "Filter Column: " & Left(col.Address(, False), 1)
End Sub

Private Sub ComboBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
   If KeyAscii = vbKeyEscape Then Me.Hide
End Sub
Private Sub CommandButton1_Click()
   ComboBox1.ListIndex = -1
   If Not Sheet1.AutoFilter Is Nothing Then Sheet1.UsedRange.AutoFilter
End Sub
Private Sub CommandButton2_Click()
   Me.Hide
End Sub
Private Sub UserForm_Click()
   Me.Hide
End Sub

Collez ce code dans le module VBA de Sheet1 :

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   With Target
      If .CountLarge = 1 Then
         removeAllFilters Me
         If .Row = 1 Then
            .Offset(1, 0).Activate
            UserForm1.setupList Me.UsedRange.Columns(.Column)
            UserForm1.Show
         End If
      End If
   End With
End Sub

Données de la feuille 1 :

Collez ce code dans un module VBA standard (ouvrez VBA : Alt + F11 cliquez sur le menu Insertion > Module)

Option Explicit

Public Sub setList(ByRef rng As Range, ByRef cmb As ComboBox)
   Dim ws As Worksheet, lst As Range, lr As Long

   If rng.Columns.Count = 1 Then
      xlEnabled False
      Set ws = rng.Parent
      removeAllFilters ws
      Set lst = ws.UsedRange.Columns(rng.Column)
      lr = getLastRow(lst, rng.Column)

      If lr > 1 Then
         With cmb
            .List = Split(getDistinct(lst, lr), ",")
            .ListIndex = -1
         End With
      End If
      xlEnabled True
   End If
End Sub

Public Sub xlEnabled(ByVal onOff As Boolean)
    Application.ScreenUpdating = onOff
    Application.EnableEvents = onOff
End Sub

Private Function getLastRow(ByRef rng As Range, ByVal lc As Long) As Long
   Dim ws As Worksheet, lr As Long
   If Not rng Is Nothing Then
      Set ws = rng.Parent
      lr = ws.Cells(rng.Row + ws.UsedRange.Rows.Count + 1, lc).End(xlUp).Row
      Set rng = ws.Range(ws.Cells(1, lc), ws.Cells(lr, lc)) 'updates rng (ByRef)
   End If
   getLastRow = lr
End Function

Private Function getDistinct(ByRef rng As Range, ByVal lr As Long) As String
   Dim ws As Worksheet, lst As String, lc As Long, tmp As Range, v As Variant, c As Double

   Set ws = rng.Parent
   lc = ws.Cells(rng.Row, rng.Column + ws.UsedRange.Columns.Count + 1).End(xlToLeft).Column
   Set tmp = ws.Range(ws.Cells(1, lc + 1), ws.Cells(lr, lc + 1))

   If tmp.Count > 1 Then
      With tmp.Cells(1, 1)
         .Formula = "=Trim(" & ws.Cells(rng.Row, lc).Address(False, False) & ")"
         .AutoFill Destination:=tmp
      End With

      tmp.Value2 = tmp.Value2       'convert formulas to values
      tmp.Cells(1, 1).ClearContents 'remove header from list
      cleanCol tmp, lc
      lr = getLastRow(tmp, lc + 1)

      lst = Join(Application.Transpose(tmp), ",")
      lst = Replace(lst, ", ", ","):   lst = Replace(lst, " ,", ",")
      v = Application.Transpose(Split(lst, ","))

      lr = UBound(v)
      ws.Range(ws.Cells(1, lc + 1), ws.Cells(lr, lc + 1)) = v
      getLastRow tmp, lc + 1

      cleanCol tmp, lc
      getLastRow tmp, lc + 1
      lst = Join(Application.Transpose(tmp), ",")
      lst = Replace(lst, ", ", ","):   lst = Replace(lst, " ,", ",")
      tmp.Cells(1, 1).EntireColumn.Clear
   End If
   getDistinct = lst
End Function

Public Sub filterColumn(ByRef col As Range, ByVal fltrCriteria As String)
   Dim ws As Worksheet, lst As Range, lr As Long

   xlEnabled False
   Set ws = col.Parent
   Set lst = ws.UsedRange.Columns(col.Column)
   lr = getLastRow(lst, col.Column)

   lst.AutoFilter
   lst.AutoFilter Field:=1, Criteria1:="*" & fltrCriteria & "*"
   xlEnabled True
End Sub

Private Sub cleanCol(ByRef tmp As Range, ByVal lc As Long)
   Dim ws As Worksheet, lr As Long

   Set ws = tmp.Parent
   tmp.RemoveDuplicates Columns:=1, Header:=xlNo
   lr = getLastRow(tmp, lc + 1)

   ws.Sort.SortFields.Add Key:=ws.Cells(lr + 1, lc + 1), Order:=xlAscending
   With ws.Sort
      .SetRange tmp
      .Header = xlNo
      .MatchCase = False
      .Orientation = xlTopToBottom
      .Apply
   End With
End Sub

Public Sub removeAllFilters(ByRef ws As Worksheet)

   If Not ws.AutoFilter Is Nothing Then ws.UsedRange.AutoFilter
   ws.Rows.Hidden = False

End Sub

En cliquant sur la colonne d'en-tête ("TEST TABLE"), la liste sera filtrée en 2 parties

Partie 1 :

• Extraire les éléments de toutes les cellules de la colonne actuelle dans la première colonne inutilisée de la feuille.
• Découper tous les éléments, en utilisant la formule TRIM() d'Excel (pas de copier-coller en utilisant le presse-papiers)
• Supprimez les doublons de la liste : .RemoveDuplicates Columns:=1, Header:=xlNo
• Trier les éléments en place (les mots dans chaque cellule ne sont pas encore séparés)
• Créez une chaîne contenant tout le texte, séparé par des virgules.

Partie 2 :

• Divisez à nouveau la chaîne de caractères
• Découpez tous les éléments (les mots des cellules sont maintenant séparés et peuvent contenir des espaces supplémentaires).
• Supprimez les doublons de la liste et triez-les à nouveau.
• Créer une chaîne finale contenant la liste filtrée
• Mettre à jour la liste déroulante de la boîte combo avec les derniers éléments

Lorsque l'utilisateur sélectionne un élément dans la liste déroulante

• Il effectuera un filtre automatique pour les cellules contenant du texte partiel.

  • Criteria1:="*" & fltrCriteria & "*" (Ex "*test3*" )

• Bouton Clear Sort supprime l'Autofiltre

• Bouton Annuler ferme le formulaire, sans enlever le filtre

• Une fois le formulaire fermé, le filtre peut être retiré de 3 manières différentes

  • La méthode standard, en utilisant la liste déroulante Autofilter, et "Select All".
  • Menu Onglet Données et en cliquant sur le Filtre bouton
  • En cliquant à nouveau sur l'en-tête de la colonne (TEST TABLE)

Liste déroulante filtrée :

Rangs filtrés en utilisant le critère "test3".

Effacer le filtre précédent :