XL 2013 Filtrage de données d'un tableau sur une autre feuille

ernest-92 à dit:

Une autre approche, en saisissant le ou les critères souhaités dans la zone N2:X3

Cliquez pour agrandir...

chris à dit:

Bonjour

On peut passer par un filtre avancé automatisé

La 1ère sub fournit la plage de critères et le nom des tableaux à la seconde qui est générique

VB:

Option Explicit
Sub FiltreT()
'Initialisation + appel du filtre d'un tableau structuré vers un autre

    Dim ZCriteres As Range
 
    Set ZCriteres = ThisWorkbook.Sheets("données").Range("P1:P2")
    Call FiltreTableau("Inscription", "Filtre", ZCriteres)

End Sub

Sub FiltreTableau(TabS_Nom As String, TabD_Nom As String, ByVal ZCriteres As Range)
'filtre d'un tableau structuré vers un autre

 
    Dim ZDest As Range, TRange As Range
    Dim Tableau As ListObject, TDest As ListObject
    Dim x1 As Integer, y2 As Long, LargeurT As Integer, HauteurT As Long
 
    Set TDest = Range(TabD_Nom).ListObject
    Set ZDest = TDest.HeaderRowRange
    Set Tableau = Range(TabS_Nom).ListObject
    Set TRange = Tableau.Range
 
 
    With TDest
        LargeurT = .ListColumns.Count
        If .ListRows.Count > 0 Then .DataBodyRange.ClearContents
        .Resize .Range.Resize(3, LargeurT)
        TRange.AdvancedFilter Action:=xlFilterCopy, _
            CriteriaRange:=ZCriteres, _
            CopyToRange:=ZDest, Unique:=False
        x1 = .Range.Column
        y2 = .Parent.Cells(Cells.Rows.Count, x1).End(xlUp).Row
        HauteurT = y2 - .Range.Row + 1
        .Resize .Range.Resize(HauteurT, LargeurT)
        .Parent.Range("" & x1 & ":" & x1 + LargeurT - 1 & "").EntireColumn.AutoFit
    End With
End Sub

Je te laisse le soin d'ajouter un bouton ou une macro évenementielle liée au changement de critères...

Cliquez pour agrandir...

chris à dit:

RE

Autre approche, pas vraiment puisque c'est aussi un filtre avancé mais ne gérant pas les tableaux structurés...

Cliquez pour agrandir...

Appo1985 à dit:

Merci bien @chris pour votre réponse.

Cependant je voudrais encore comprendre. Que signifie ThisWorkbook.Sheets ("données").Range("P12") dans ce code.

Quelle adaptation puis je faire si la plage de critères est nommée "Masculin"

Que dois-je faire si je veux trier en même temps par ordre alphabétique ?
Merci.

Cliquez pour agrandir...

chris à dit:

RE

Si tu regardes le fichier que j'ai joint tu vois sur l'onglet des inscriptions les deux cellules P12 qui servent de critères et omù tu peux remplacer Masculin par Féminin...

Cliquez pour agrandir...

chris à dit:

RE

Ordre alpha de quelle(s) colonne(s) ?

Cliquez pour agrandir...

chris à dit:

RE

Remplace la 1ère Sub par

VB:

Sub FiltreT()
'Initialisation + appel du filtre d'un tableau structuré vers un autre

    Dim ZCriteres As Range
   
    Set ZCriteres = ThisWorkbook.Sheets("données").Range("P1:P2")
    Call FiltreTableau("Inscription", "Filtre", ZCriteres)
   
    With Range("Filtre").ListObject
    .Sort.SortFields.Clear
    .Sort.SortFields.Add2 _
    Key:=Range("Filtre[Nom]"), SortOn:=xlSortOnValues, Order:=xlAscending, _
    DataOption:=xlSortTextAsNumbers
    With .Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .Apply
    End With
End With

End Sub

Cliquez pour agrandir...

• à l'ouverture du fichier
• au changement de critère sur la feuille "liste" - cellule G9 que l'on a nommée "Genre"
• à l'activation de la feuille "liste"

• dans le module de ThisWorkbook (ouverture du classeur)
• dans le module de la feuille "liste" (changement de genre désiré et activation de la feuille)
• et bien sûr dans module1, on trouve la procédure principale (brute et aussi commentée)

Sub FiltrerTrier()
Dim t, Critere As String, n&, i&, j&
   On Error GoTo FIN
   Application.EnableEvents = False
   Application.ScreenUpdating = False
   Critere = Replace(Left(Range("genre"), 1), "T", "") & "*"
   t = Sheets("données").ListObjects(1).DataBodyRange.Columns("a:f")
   For i = 1 To UBound(t)
      If UCase(t(i, 6)) Like Critere Then n = n + 1: For j = 2 To UBound(t, 2): t(n, j) = t(i, j): Next
   Next i
   With Sheets("liste").ListObjects(1)
      If Not .DataBodyRange Is Nothing Then .DataBodyRange.Delete
      If Not n = 0 Then
         .Range(2, 1).Resize(n, UBound(t, 2)) = t
         .Range.Sort key1:=.ListColumns(2), order1:=xlAscending, Header:=xlYes, key2:=.ListColumns(3), order2:=xlAscending
      End If
   End With
FIN:
   Application.EnableEvents = True: Beep
End Sub