Microsoft 365 Fonction Filtrage

Private Sub Worksheet_Activate()
Dim n&, crit As Range, i&, j&
Application.ScreenUpdating = False
Columns(1).Delete 'RAZ
[A1] = "Liste"
n = 1
With Sheets("Listes")
    '---liste des critères---
    With .[C1].CurrentRegion
        If .Rows.Count = 1 Then Exit Sub
        Set crit = .Offset(1).Resize(.Rows.Count - 1)
    End With
    '---copie du tableau source---
    With .[A1].CurrentRegion
        For i = 2 To .Rows.Count
            If Application.CountIf(crit, .Cells(i, 1)) Then
                If i > 2 And Application.CountIf(crit, .Cells(i - 1, 1)) = 0 Then
                    n = n + 1
                    .Cells(i - 1, 1).Copy Cells(n, 1) 'copie la ligne précédente
                End If
                n = n + 1
                .Cells(i, 1).Copy Cells(n, 1) 'copie la ligne courante
            End If
        Next
    End With
End With
Columns(1).AutoFit 'ajuste la largeur
End Sub

Private Sub Worksheet_Activate()
Dim d As Object, i&, tablo, n&
With Sheets("Listes")
    '---liste des critères sans doublon---
    Set d = CreateObject("Scripting.Dictionary")
    d.CompareMode = vbTextCompare 'la casse est ignorée
    With .[C1].CurrentRegion
        For i = 2 To .Rows.Count
            d(.Cells(i, 1).Value) = ""
        Next i
    End With
    '---tableau source et résultats---
    tablo = .[A1].CurrentRegion.Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
    For i = 2 To UBound(tablo)
        If d.exists(tablo(i, 1)) Then
            If i > 2 And Not d.exists(tablo(i - 1, 1)) Then
                    n = n + 1
                    tablo(n, 1) = tablo(i - 1, 1)
                End If
                n = n + 1
                tablo(n, 1) = tablo(i, 1)
            End If
    Next i
End With
'---restitution---
If FilterMode Then ShowAllData 'si la feuille est filtrée
With [A2] '1ère cellule de destination, à adapter
    If n Then .Resize(n) = tablo
    .Offset(n).Resize(Rows.Count - n - .Row + 1).ClearContents 'RAZ en dessous
End With
Columns(1).AutoFit 'ajuste la largeur
End Sub