Microsoft 365 Filtrer dans une variable-tableau : possible ?

klin89 à dit:

Bonjour à tous, 🙂

Par filtrer une variable tableau, je ne sais pas trop ce que tu entends 😏
Sinon un p'tit test avec la fonction Filter :

VB:

Sub test()
    Dim x, Arr()
    With Sheets("Pannes").Cells(1).CurrentRegion
        x = Filter(.Parent.Evaluate("transpose(if((" & .Columns(8).Address & "=""FABRICATION""),row(1:" & .Rows.Count & ")))"), False, 0)
        If UBound(x) = -1 Then Exit Sub
        Arr = Application.Index(.Value2, Application.Transpose(x) _
                                        , Evaluate("column(" & .Rows(1).Address & ")"))
        'Arr = Application.Index(.Value2, Application.Transpose(x), Evaluate("column(a:h)"))
        If UBound(x) = 0 Then
            Sheets("Fabrication").[A2].Resize(, UBound(Arr)) = Arr
        Else
            Sheets("Fabrication").[A2].Resize(UBound(Arr), UBound(Arr, 2)) = Arr
        End If
        Sheets("Fabrication").Cells(1).CurrentRegion.Columns(1).NumberFormat = "m/d/yyyy"
    End With
End Sub

klin89

Cliquez pour agrandir...

job75 à dit:

Bonjour le forum,

Allez j'en remets une couche.

Classiquement pour aller vite on utilise des tableaux VBA :

VB:

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim critere$, tablo, ub%, rfesu(), i&, n&, j%, dbrc&
critere = UCase(Replace(Sh.Name, "é", "e")) 'si toute la colonne 8 est en majuscules
With Sheets("Pannes")
    If Sh.Name = .Name Then Exit Sub
    tablo = .ListObjects(1).Range 'matrice, plus rapide
End With
ub = UBound(tablo, 2)
ReDim resu(1 To UBound(tablo), 1 To ub)
For i = 1 To UBound(tablo)
    If tablo(i, 8) = critere Then
        n = n + 1
        For j = 1 To ub: resu(n, j) = tablo(i, j): Next j
    End If
Next i
With Sh.ListObjects(1)
    If Not .DataBodyRange Is Nothing Then dbrc = .DataBodyRange.Rows.Count
    With .Range
        .AutoFilter: .AutoFilter 'affiche tout
        If n > dbrc Then .Rows(2).Resize(n - dbrc).Insert xlDown, xlFormatFromRightOrBelow 'nécessaire si la ligne Total est affichée
        .Cells(2, 1).Resize(n, ub) = resu
        If n < dbrc Then .Rows(n + 2).Resize(dbrc - n).Delete xlUp 'lignes excédentaires
    End With
End Sub

Edit : on voit que seules les lignes excédentaires sont supprimées à la fin.

Sur 224 000 lignes l'activation de la feuille "Fabrication" se fait chez moi en 1,2 seconde, record battu

A+

Cliquez pour agrandir...

mapomme à dit:

Bonjour à tous,

La p'tiote méthode à ma pomme qui ne modifie ni l'ordre des lignes des données sources ni l'ordre des lignes résultats vis à vis de la source. Le seul tri dans le code ne modifie pas l'ordre relatif des lignes triées (car le tri d'Excel est stable).

VB:

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim lsto As ListObject, topD#, ref$, nref&, ncol&, nlig&, n&, i&, j&, xrg1 As Range, xrg2 As Range
   topD = Timer                                                         ' timer début
   Application.ScreenUpdating = False                                   ' on fige l'écran
   If LCase(Sh.Name) = LCase("Pannes") Then Exit Sub                    ' si c'est la feuille "Pannes", on quitte
   ref = Sh.Name                                                        ' la référence à garder
   nref = Sheets("Pannes").ListObjects(1).ListColumns("Service").Index  ' index de la colonne "Service"
   ncol = Sheets("Pannes").ListObjects(1).ListColumns.Count             ' nbre colonnes de la source
   nlig = Sheets("Pannes").ListObjects(1).ListRows.Count + 1            ' nbre lignes de la source
   Columns("a").CurrentRegion.EntireColumn.Clear                        ' effacement du précédent résultat
   [a1].Resize(nlig, ncol).Value2 = Sheets("Pannes").ListObjects(1).Range.Value2          ' copie de la source vers la feuille cible
   [a1].CurrentRegion.Sort Cells(1, ncol), xlAscending, Header:=xlYes, MatchCase:=False   ' tri
   ' première cellule égale à ref
   Set xrg1 = Columns(ncol).Find(what:=ref, LookIn:=xlValues, lookat:=xlWhole, After:=Cells(1, ncol), searchdirection:=xlNext, MatchCase:=False)
   If Not xrg1 Is Nothing Then
      ' dernière cellule égale à ref
      Set xrg2 = Columns(ncol).Find(what:=ref, LookIn:=xlValues, lookat:=xlWhole, After:=Cells(1, ncol), searchdirection:=xlPrevious, MatchCase:=False)
      Range(Cells(xrg2.Row + 1, 1), Cells(nlig + 1, ncol)).Delete shift:=xlShiftUp            ' suppression des lignes après
      If xrg1.Row > 2 Then Range(Cells(2, 1), Cells(xrg1.Row - 1, ncol)).Delete shift:=xlShiftUp   ' suppression des lignes avant
      Set lsto = ActiveSheet.ListObjects.Add(xlSrcRange, [a1].CurrentRegion, , xlYes)              ' plage en tableau structuré
      lsto.Name = ref                                                                              ' nom du TS
      MsgBox "Pour le critère <" & ref & "> : " & Format(lsto.ListRows.Count, "#,##0\ lignes copiées  en ") & _
            Format(Timer - topD, "0.00\ sec.")
   Else
      Range(Cells(1, 1), Cells(Rows.Count - 1, ncol)).Delete shift:=xlShiftUp    ' pas de ligne avec ref -> on efface tout
      MsgBox "Pour le critère <" & ref & "> : aucune ligne copié en " & Format(Timer - topD, "0.00\ sec.")
   End If
End Sub

Cliquez pour agrandir...

vgendron à dit:

et pour finir..
sur la TS source, juste un segment pour filtrer directement sur place

et un onglet "Général" (pour remplacer les autres) qui permet de choisir le service, et la Requete se met à jour

Cliquez pour agrandir...

ChTi160 à dit:

Re
Un autre fichier
Jean marie

Cliquez pour agrandir...