XL 2019 Excel - utilisation des unbound pour grande base de donnees

[Lordpeter]

Bonjour

je viens vers vous car vous etes des faiseurs de miracles et je bloque sur un souci

voila ai une base de donnees 20,000 lignes et de 40 colonnes

mon obectif est de faire supprimer les lignes inutiles et cela base sur des valeurs connus localisees en colonne K

on m'a ait aide pour un pb inverse ou je voulais supprimer les lignes SI lune des valeurs de liste sont reperes




Application.ScreenUpdating = False ' Inhibition des events et freeze screen.
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Fin = Range("a" & Rows.Count).End(xlUp).Row
Tablo = Range("F1:G" & Fin) ' Transfert données F et G dans tableau ( colonnes 6 et 7 )
Liste = Array("*PendingRMA*", "*CDG90.1-1.220517868*")
For N = 1 To UBound(Tablo) ' Pour toutes les lignes
If Tablo(N, 2) = "false" Then ' Si 2eme élément=false cad colonne 7
Tablo(N, 1) = Chr(1) ' On met CAR(1) dans tableau
Else
Valeur = Tablo(N, 1): Tablo(N, 1) = ""
For i = 1 To UBound(Liste) ' Sinon si la cellule contient un des mot de la liste
If Valeur Like Liste(i) Then
Tablo(N, 1) = Chr(1) ' On met CAR(1) dans tableau de sortie
Exit For ' Et on sort, inutile de continuer
End If
Next i
End If
Next N
Columns("A:A").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove ' Insertion colonne en A
[A1].Resize(UBound(Tablo, 1), 1) = Tablo ' On met la 1ere colonne de Tablo en colonne A
With Range("A1:A" & Fin)
.EntireRow.Sort .Cells, xlAscending ' Tri pour regrouper et accélérer
.SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete ' Suppression des lignes qui contiennent CAR(1) en A
.Delete Shift:=xlToLeft ' Effacement colonne formules
End With
Columns.AutoFit 'Ajustement largeurs colonnes
With ActiveSheet.UsedRange: End With 'Ajustement barres de défilement

==========================

dans ce nouveau projet cest tout linverse

Je souhaite garder que les LIGNES si en colonne K , lune des valeurs que ai mis dans le vba ' liste' est inclus

je maitrise pas du tout la partie des ubound, array, tableau a double dimension.

je vous remercie infiniment pour votre aide

Pierre

 

[vgendron]

Bonjour

Peux tu mettre un bout de fichier en exemple.... pas besoin des 20 000 lignes.. une dizaine suffit

 

[Lordpeter]

en voici un , merci de votre aide

 

[vgendron]

Voir la PJ

Note: la dernière ligne de code qui supprime les lignes vides en colonne K risque d'être LA ligne qui allonge le temps d'execution...

 

[mapomme]

Bonjour à tous,

ERRATA : J'ai fait l'opposé de ce qui était demandé. Il faut en faite ne garder que les lignes comportant en colonne K une des valeurs de la liste. Donc voici le code de la v2 qui le fait.

Les ordres de grandeur de la durée d'exécution restent globalement similaires.

Un code assez rapide :

Sub SupprLigne()
Const Liste = "FTL4C1QE1L;LB9"
Dim der&, t, r, i&, s, t1#
   t1 = Timer
   Application.ScreenUpdating = False
   If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
   der = ActiveSheet.Cells(Rows.Count, "k").End(xlUp).Row
   On Error GoTo FIN:
   Columns("L:L").Insert
   Columns("k:k").Copy
   Columns("L:L").PasteSpecial xlPasteValues
   For Each s In Split(Liste, ";")
      Columns("L:L").Replace what:=s, replacement:="=na()", lookat:=xlWhole
   Next s
   t = Range("L1:L" & der)
   For i = 1 To UBound(t)
      If IsError(t(i, 1)) Then t(i, 1) = i Else t(i, 1) = "=na()"
   Next i
   Range("L1:L" & der) = t
   Rows("2:" & der).Sort key1:=Range("L1"), order1:=xlAscending
   On Error Resume Next
   Range("L1:L" & der).SpecialCells(xlCellTypeConstants, xlErrors).EntireRow.Delete
FIN:
   Columns("L:L").Delete
   MsgBox "Exécution en : " & Format(Timer - t1, "0.00\ sec.")
End Sub

 

[mapomme]

Re,

@vgendron ,
En fait pas rafraichi. Ma méthode est analogue à celle de @vgendron ! Désolé .

 

[vgendron]

pas de quoi etre désolé

ce qui m'embete dans nos deux solutions, c'est l'instruction specialcells(.....).delete..
j'ai peur qu'avec 20 000 lignes.. cette simple instruction soit chronophage..
as tu une solution de quick sort DESCENDANT ? pour mettre les lignes vides en bas. ainsi. plus besoin de delete..

 

[mapomme]

ce qui m'embete dans nos deux solutions, c'est l'instruction specialcells(.....).delete..

Comme il y a un tri selon la colonne L , le Range("L1:L" & der).SpecialCells(xlCellTypeConstants, xlErrors).EntireRow.Delete sélectionne une plage contigüe et donc la suppression est très rapide.

Pour 20 000 lignes, environ 0,95 s sur mon micro portable.

 

[mapomme]

Re,

Le fichier utilisé.
Sur mon PC fixe, pour 20 000 lignes, la durée d'exécution est entre 0,42 s et 0,50 s. (env. 4,8 s pour 200 000 lignes)

 

[vgendron]

bah voila, c'est ce que je pensais.. chez moi, ma macro donne 37s..
et la tienne executée sur mon PC 1,5s

 

[vgendron]

Hello
Je reviens par ici, car je suis tombé sur une macro de quickSort en ordre descendant (de JBoisgontier)

Sub FiltrerTab()
t1 = Timer
    Application.ScreenUpdating = False                  ' Inhibition des events et freeze screen.
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    Dim tablo() As Variant
    Liste = Array("*FTL4C1QE1L*", "*LB9*") 'liste des éléments à garder
    
    With ActiveSheet
        LastLine = .Range("A" & .Rows.Count).End(xlUp).Row
        LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        
        'Tablo = .Range("A1").CurrentRegion.Value 'Transfert de TOUT le tableau sans passer par les LastLine et LastCol
        tablo = .Range("A2").Resize(LastLine - 1, LastCol).Value
        
        For i = 1 To UBound(tablo, 1)                         ' Pour toutes les lignes du tablo vba
            For j = 1 To UBound(Liste) 'on parcourt tous les éléments de la liste à garder
                If Not (tablo(i, 11) Like Liste(j)) Then 'si ce n'est PAS un élément à garder
                    For k = LBound(tablo, 2) To UBound(tablo, 2) 'on efface la ligne entière==> on pourrait se contenter de vider la colonne K
                        tablo(i, k) = ""
                    Next k
                End If
            Next j
        Next i
    End With
    Call Quick(tablo, LBound(tablo), UBound(tablo), 11, False)
    
    With ActiveSheet
        .Range("A2").Resize(UBound(tablo, 1), UBound(tablo, 2)) = tablo
        '.Range("K2").Resize(UBound(tablo, 1)).SpecialCells(xlCellTypeBlanks).EntireRow.Delete 'supprime les lignes dont la colonne K est vide
    End With
    

Application.ScreenUpdating = True
Application.EnableEvents = True
MsgBox "Exécution en : " & Format(Timer - t1, "0.00\ sec.")
End Sub

Sub Quick(a(), gauc, droi, col, ordre) ' Quick sort
  ref = a((gauc + droi) \ 2, col)
  g = gauc: d = droi
  Do
    Do While IIf(ordre, a(g, col) < ref, a(g, col) > ref): g = g + 1: Loop
    Do While IIf(ordre, ref < a(d, col), ref > a(d, col)): d = d - 1: Loop
    If g <= d Then
      For i = LBound(a, 2) To UBound(a, 2)
         Temp = a(g, i): a(g, i) = a(d, i): a(d, i) = Temp
      Next i
      g = g + 1: d = d - 1
   End If
  Loop While g <= d
  If g < droi Then Call Quick(a, g, droi, col, ordre)
  If gauc < d Then Call Quick(a, gauc, d, col, ordre)
End Sub

peut etre que l'auteur de ce post reviendra un jour dire merci...

 

[Lordpeter]

bonjour

un grand merci de vos retours j'y jette un oeil et reviens vers vous, encore merci de votre soutien et contribution