Microsoft 365 Filtrer dans une variable-tableau : possible ?

[BenHarber]

Bonjour le Forum,
Une petite question de principe (…et je m’en excuse par avance si elle est complètement saugrenue 😌) :

Est-ce qu’il est « VBAment » possible, à partir d’une VARIABLE-TABLEAU (comportant x lignes et y colonnes), de « filtrer » certaines données pour les coller sur une feuille Excel ? (je sais faire la manip à partir d’un tableau Excel mais je me demandais si on pourrait le faire à partir d’une variable-tableau).

Merci d’avance pour vos idées…et votre indulgence !

 

[TooFatBoy]

Dans l'idéal, j'aurais aimé ne pas du tout "toucher" l'ordre des données du tableau.

Tu parles là du tableau dans la feuille ?

Je ne comprends pas car le filtrage ne change pas l'ordre des lignes.

 

[ChTi160]

Re Bonjour
Question a l'origine les dates de la Colonne "Date" sont triées dans quel ordre ?
diverses procédures agissent sur le Tri de la Colonne "Service" !
Il suffirait de trier en Fin de Procédure la Colonne "Date" , dans l'ordre Initial !
Bonne Journée
Jean marie

 

[BenHarber]

Bonjour @ChTi160
Encore une fois, cet exemple "Base_pannes" est théorique : peu importe ici l'ordre de tri réellement constaté (qui peut-être sur la colonne "Services", la colonne "Date" ou n'importe quel autre champs).
Je cherchais surtout, quel que soit le fichier sur lequel je suis appeler à travailler, de ne pas toucher (sauf en filtrant) le tableau de l'onglet de base (ici "pannes") : que ce soit l'ordre des données, l'insertion temporaire de colonnes, etc....
Un peu dans la philosophie "Vous êtes priés de laisser les lieux dans l'état où vous l'avez trouvé". 😁

Et fermer le fichier sans l'enregistrer n'est pas une solution satisfaisante.

Mais pas de pb : avec toutes les solutions que vous m'avez fournies, j'ai de quoi m'amuser! 👍

 

[ChTi160]

Re
Ok !
Les dates ne sont pas dans un ordre définit a l'ouverture du fichier donc pas de tri sur dates ni sur services ?
Jean marie

 

[ChTi160]

Re
ce que j'ai adapté !

Option Explicit
    Dim topD As Date, topF As Date
    Dim TabBDD As Variant, Tab_Resultat As Variant
    Dim Tab_Temp() As Variant, TabInit As Variant
    Dim Lgn As Long, NbLignes As Long
    Dim Service As String
    Dim Col As Long
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
    Application.ScreenUpdating = False
    With Sheets("Pannes")
        If Sh.Name = .Name Then Exit Sub
          ' Démarrer le chronomètre
        topD = Time
        TabInit = .ListObjects(1).DataBodyRange.Value 'on récupére le Tableau a l'origine
                         ' Trier par  "Service" (ascendant)
             With .ListObjects(1).Sort  'On va trier le Tableau en fonction des Valeurs des Colonnes « Date » et « Arrivée »du Tableau Structuré
                      With .SortFields
                             .Clear
                             .Add2 Key:=Range("t_Pannes").ListObject.ListColumns("Service").DataBodyRange, _
                          SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                      End With 'SortFields
                             .Header = xlYes ' Le tableau contient des en-têtes
                             .Apply
             End With 'Sort
        ' Charger la base de données Triée en mémoire
        TabBDD = .ListObjects(1).DataBodyRange.Value
        NbLignes = UBound(TabBDD, 1) 'On définit le Nombre de Ligne du tableau
        ' Initialiser le service à rechercher
        Service = UCase(Replace(Sh.Name, "é", "e"))
        ' Créer un tableau dynamique sans ReDim Preserve (meilleure performance)
        Dim TmpArr() As Variant
        Dim NbMatches As Long
        ReDim TmpArr(1 To NbLignes, 1 To UBound(TabBDD, 2)) ' Taille max possible
        ' Filtrer les lignes et les stocker dans TmpArr
                           NbMatches = 0
        For Lgn = 1 To NbLignes
            If TabBDD(Lgn, 8) = Service Then ' Si le service correspond
                NbMatches = NbMatches + 1
                ' Copier la ligne entière manuellement
                For Col = 1 To UBound(TabBDD, 2)
                    TmpArr(NbMatches, Col) = TabBDD(Lgn, Col)
                Next Col
            End If
        Next Lgn
        ' Si des données ont été trouvées, on réduit la taille du tableau
        If NbMatches > 0 Then
            ReDim Tab_Temp(1 To NbMatches, 1 To UBound(TabBDD, 2))
            For Lgn = 1 To NbMatches
                For Col = 1 To UBound(TabBDD, 2)
                    Tab_Temp(Lgn, Col) = TmpArr(Lgn, Col)
                Next Col
            Next Lgn
            ' Supprimer les anciennes données de la feuille Cible
            If Not Sh.ListObjects(1).DataBodyRange Is Nothing Then
                     Sh.ListObjects(1).DataBodyRange.Delete xlUp
            End If
            ' Insérer les nouvelles données
            Sh.ListObjects(1).Range.Cells(1, 1).Offset(1, 0).Resize(UBound(Tab_Temp, 1), UBound(Tab_Temp, 2)) = Tab_Temp
        End If
               topF = Time
        MsgBox "Le traitement a duré " & Format(topF - topD, "HH:MM:SS")
    End With
    With Sheets("Pannes").ListObjects(1) 'On va remettre les données comme elles etaient au Départ
       .DataBodyRange.Cells(1, 1).Resize(UBound(TabInit, 1), UBound(TabInit, 2)) = TabInit
    End With
 ' Réactiver l'affichage et afficher la durée du traitement
        Application.ScreenUpdating = True
    Set TabInit = Nothing: Erase Tab_Temp: NbMatches = 0:Set Sh= Nothing
End Sub

Bonne Journée
Jean marie
Bonne Journée
Jean marie

 

[job75]

Oui BenHarber trier la colonne 8 du tableau source est une bonne solution.

Je cherchais surtout, quel que soit le fichier sur lequel je suis appeler à travailler, de ne pas toucher (sauf en filtrant) le tableau de l'onglet de base (ici "pannes") : que ce soit l'ordre des données, l'insertion temporaire de colonnes, etc....
Un peu dans la philosophie "Vous êtes priés de laisser les lieux dans l'état où vous l'avez trouvé". 😁

Ce n'est pas très difficile, il suffit à la fin de remettre le tableau source dans l'ordre initial.

Avec cette macro il faut quand même que la colonne à filtrer soit toujours la colonne 8 :

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim critere$, h&, P As Range
critere = Replace(Sh.Name, "é", "e")
Application.ScreenUpdating = False
With Sheets("Pannes")
    If Sh.Name = .Name Then Exit Sub
    With .ListObjects(1).Range
        .AutoFilter: .AutoFilter 'affiche tout
        .Columns(8).EntireColumn.Insert 'colonne auxiliaire
        .Cells(2, 8) = 1: .Cells(2, 8).Resize(.Rows.Count - 1).DataSeries 'numérotation
        .Sort .Columns(9), Header:=xlYes 'tri pour regrouper
        h = Application.CountIf(.Columns(9), critere)
        If h Then Set P = .Rows(Application.Match(critere, .Columns(9), 0)).Resize(h)
    End With
    With Sh.ListObjects(1).Range
        .AutoFilter: .AutoFilter 'affiche tout
        If Not .ListObject.DataBodyRange Is Nothing Then .ListObject.DataBodyRange.Delete xlUp
        If h Then .Columns(8).EntireColumn.Insert: P.Copy .Cells(2, 1): .Columns(8).EntireColumn.Delete
    End With
    With .ListObjects(1).Range
        .Sort .Columns(8), xlAscending, Header:=xlYes 'retour à l'ordre initial
        .Columns(8).EntireColumn.Delete 'supprime la colonne auxiliaire
    End With
End With
End Sub

J'ai testé en recopiant le tableau source sur 224 000 lignes comme fait précédemment.

L'activation de la feuille "Fabrication" se fait en 2,1 secondes, c'est un peut plus rapide que la macro de mon post #50.

 

[vgendron]

Hello

Sinon pour ne pas toucher la feuille
1) tu mets TOUT dans un tablo VBA (puisque c'est la demande initiale)
2) tu effaces toutes les lignes ne répondant pas au critère (effacer = mettre "" dans la ligne)
3) quicksort pour mettre les lignes vides en bas
4) copier le tableau dans la feuille
5) et éventuellement supprimer les lignes vides de la table structurée si des lignes vides ont été ajoutées (je ne sais pas ce que ca fait quand on colle un tablo vba qui contient des lignes vides en bas)

 

[ChTi160]

Re
Bonjour Gérard
le problème c'est que l'ordre n'est pas forcément Lol
BenHarber dit #63 :

Encore une fois, cet exemple "Base_pannes" est théorique : peu importe ici l'ordre de tri réellement constaté (qui peut-être sur la colonne "Services", la colonne "Date" ou n'importe quel autre champs).

With .ListObjects(1).Range
        .Sort .Columns(8), xlAscending, Header:=xlYes 'retour à l'ordre initial

Bonne Journée
Merci de ce que tu fais !
Cordialement
jean marie

 

[mapomme]

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).

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

 

[vgendron]

sinon.. il y a aussi Power Query..

 

[job75]

Plutôt qu'une colonne auxiliaire il est plus simple de travailler à partir d'une copie de la feuille source :

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim critere$, h&, P As Range
critere = Replace(Sh.Name, "é", "e")
Application.ScreenUpdating = False
With Sheets("Pannes")
    If Sh.Name = .Name Then Exit Sub
    .Copy 'document auxiliaire
End With
With ActiveWorkbook.Sheets(1).ListObjects(1).Range
    .AutoFilter: .AutoFilter 'affiche tout
    .Sort .Columns(8), Header:=xlYes 'tri pour regrouper
    h = Application.CountIf(.Columns(8), critere)
    If h Then Set P = .Rows(Application.Match(critere, .Columns(8), 0)).Resize(h)
End With
With Sh.ListObjects(1).Range
    .AutoFilter: .AutoFilter 'affiche tout
    If Not .ListObject.DataBodyRange Is Nothing Then .ListObject.DataBodyRange.Delete xlUp
    .Columns(8).EntireColumn.Insert: .Columns(8).EntireColumn.Delete 'nécessaire si la ligne Total est affichée
    If h Then P.Copy .Cells(2, 1)
End With
ActiveWorkbook.Close False 'ferme le document auxiliaire
End Sub

Edit : curieusement il faut une petite gymnastique si la ligne Total est affichée...

C'est un peu plus long, avec 224 000 lignes => 2,4 secondes.

 

[vgendron]

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

 

[ChTi160]

Re
Un autre fichier
Jean marie

 

[klin89]

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 :

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

 

[job75]

Bonjour le forum,

Allez j'en remets une couche.

Classiquement pour aller vite on utilise des tableaux VBA :

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim critere$, tablo, ub%, rfesu(), i&, n&, j%, dbrc&, total As Boolean
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
Application.ScreenUpdating = False
With Sh.ListObjects(1)
    If Not .DataBodyRange Is Nothing Then dbrc = .DataBodyRange.Rows.Count
    total = .ShowTotals: .ShowTotals = False 'ôte la ligne Total
    With .Range
        .AutoFilter: .AutoFilter 'affiche tout
        .Cells(2, 1).Resize(n, ub) = resu 'restitution
        If n < dbrc Then .Rows(n + 2).Resize(dbrc - n).Delete xlUp 'lignes excédentaires
    End With
    .ShowTotals = total 'état initial
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+