XL 2019 Reduire le temps d'excution VBA - code mal optimisé

[pasquetp]

Bonjour,

je constate un chargement tropppp long sur l'execution d'une macro

j'aimerai savoir comment reduire ce temps

la partie du code ou cest super long est situé sur des suppressions de ligne basé sur des criteres de mots sur la feuille et si le mot clé est trouvé la ligne doit degager

vous verrez la liste ci dessous

voici la partie du code ou ca mouline a 2 a l'heure

auriez vous une idee pour accelerer le code? d'ailleurs je pense que mettre les mots clé sur une feuille excel serait plus simple si jen ai d'autres a ajouter ce qui sera le cas, en effet je vais sans aucun doute devoir ajouter des mots clé au fil du temps

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

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

fin = Range("a" & Rows.Count).End(xlUp).Row
For b = fin To 2 Step -1

If Cells(b, 7) = "false" Or Cells(b, 7) = False Or Cells(b, 6).Value Like "*/A*" Or _
Cells(b, 6).Value Like "*RPIDEPLOY*" Or _
Cells(b, 6).Value Like "*REDMEDIAI*" Or _
Cells(b, 6).Value Like "*OVERFLOW*" Or Cells(b, 6).Value Like "*HDDPENDING*" Or Cells(b, 6).Value Like "*LEVER*" Or Cells(b, 6).Value Like "*MINIRACK*" Or Cells(b, 6).Value Like "*SHADE*" Or Cells(b, 6).Value Like "*MR6*" Or _
Cells(b, 6).Value Like "*MR1*" Or _
Cells(b, 6).Value Like "*MR2*" Or _
Cells(b, 6).Value Like "*GONE*" Or _
Cells(b, 6).Value Like "*DEGUASSER*" Or _
Cells(b, 6).Value Like "*HOTRACK*" Or _
Cells(b, 6).Value Like "*DESTROYER*" Or _
Cells(b, 6).Value Like "*DEPLOYED*" Or _
Cells(b, 6).Value Like "*DEGAUS*" Or _
Cells(b, 6).Value Like "*DECOM*" Or _
Cells(b, 6).Value Like "*2-4.40*" Or _
Cells(b, 6).Value Like "*2-3.30*" Or _
Cells(b, 6).Value Like "*1-1.11*" Or _
Cells(b, 6).Value Like "*TRAKA*" Or _
Cells(b, 6).Value Like "*CRUSH*" Or _
Cells(b, 6).Value Like "*/B*" Or _
Cells(b, 6).Value Like "*/a*" Or _
Cells(b, 6).Value Like "*/b*" Or _
Cells(b, 6).Value Like "*MPROJECT*" Or _
Cells(b, 6).Value Like "*MSECURECAGE*" Or _
Cells(b, 6).Value Like "*SHREDDER*" Or _
Cells(b, 6).Value Like "*CRIB*" Then

Rows(b).Delete Shift:=xlUp

End If
Next

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

si un fichier est necessaire, hesitez pas a me le remonter

je vous remercie

Pierre

 

[sylvanu]

Bonjour Pasquerp,
Naturellement qu'un tel code doit être long. Il faut passer par un array pour éviter toutes ces lectures. Et tous ces OU qu'il execute meme si une seule valeur siffirait pour decider.
Mais un fichier test serait le bienvenu pour tester une solution possible.

 

[sylvanu]

Sinon testez ce code,

Sub Nettoyage()
    Dim Tablo, Tablo2, Liste, N%, i%
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    Fin = Range("a" & Rows.Count).End(xlUp).Row
    Tablo = Range("A1:Z" & Fin)                     ' Transfrt données dans tableau
    ReDim Tablo2(UBound(Tablo))                     ' Nouveau tableau de sortie, même taille
    Liste = Array("", "*/A*", "*RPIDEPLOY*", "*REDMEDIAI*", "*OVERFLOW*", "*HDDPENDING*", "*LEVER*", _
            "*MINIRACK*", "*SHADE*", "*MR6*", "*MR1*", "*MR2*", "*GONE*", "*DEGUASSER*", "*HOTRACK*", _
            "*DESTROYER*", "*DEPLOYED*", "*DEGAUS*", "*DECOM*", "*2-4.40*", "*2-3.30*", "*1-1.11*", _
            "*TRAKA*", "*CRUSH*", "*/B*", "*/a*", "*/b*", "*MPROJECT*", "*MSECURECAGE*", "*SHREDDER*", "*CRIB*")
    For N = 1 To UBound(Tablo)                          ' Pour toutes les lignes
        If Tablo(N, 7) = False Then                     ' Si 7eme élément=false
            Tablo2(N) = Chr(1)                          ' On met CAR(1) dans tableau de sortie
        Else
            Valeur = Tablo(N, 6)
            For i = 1 To UBound(Liste)                  ' Sinon si la cellule contient un des mot de la liste
                If Valeur Like Liste(i) Then
                    Tablo2(N) = 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
    Range("A1").Resize(Fin, 1).Value = Application.Transpose(Tablo2)            ' On met le Tablo2 en colonne A
    With Range("A1:A" & Fin)
        .EntireRow.Sort .Cells, xlDescending            ' 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
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
End Sub

 

[pasquetp]

Bonjour Sylvanu

merci de votre retour

je vous envoie ce fichier au plus vite des que je finis mon travail

je fais au plius vite

merci

 

[pasquetp]

voici le fichier

merci egalement des commentaires ca a l'air top les tablo j'ai envie d'apprendre.

j'ai tenté la macro mais il reste les lignes avec les falses (il ne doit rester que les true)

sur les 930 false, il en reste apres 270

egalement je constate que bcp de mots clée sont restés a la fin et ont eviter detre supprimé

j'ignore comment corriger cela, auriez vous une idée?

pour faire des test a repetitions, j'ai cree la page liste pleine avec la base de donnée sans retouche et vous avez la feuille test pour tester le code

je precise que dans le code jai rajouré en debut de votre script :

Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
Columns("F:F").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("F1") = "BIN"
Range("F2").FormulaR1C1 = "=RC[-1] & ""."" & RC[-5]"
Columns("F:F").EntireColumn.AutoFit
Range("F2:F" & Range("A" & Rows.Count).End(xlUp).Row).FillDown
Range("F2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Range("F2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

je vous remercie infiniment

 

[sylvanu]

Bonjour,
Voir PJ. J'ai simplifié la macro, le second tableau est inutile.
Sur mon PC avec votre fichier ça met 0.25s, ce qui est raisonnable.
Pour les False c'est normal, False est un mot clé du VBA et moi je cherchait cet état : False alors qu'il fallait chercher la chaine de caractères "False".

 

[pasquetp]

CA a l'air de trop bien marcher LOLLL

je regarderai sur ma base de données entiere et je reviens vers vous des que possible

un GROS merci a vous pour votre aide

je vous tiens au courant des que possible

 

[pasquetp]

bonjour,

j'ai a peu pres compris la macro , enfin j'espere

j'aimerai savoir si la liste array peut elle etre listé sur une feuille excel plutot que sur vba ?

Liste = Array("", "*/A*", "*RPIDEPLOY*", "*REDMEDIAI*", "*OVERFLOW*", "*HDDPENDING*", "*LEVER*", _
"*MINIRACK*", "*SHADE*", "*MR6*", "*MR1*", "*MR2*", "*GONE*", "*DEGUASSER*", "*HOTRACK*", _
"*DESTROYER*", "*DEPLOYED*", "*DEGAUS*", "*DECOM*", "*2-4.40*", "*2-3.30*", "*1-1.11*", _
"*TRAKA*", "*CRUSH*", "*/B*", "*/a*", "*/b*", "*MPROJECT*", "*MSECURECAGE*", "*SHREDDER*", "*SNOWBALL.SB10*", "*CRIB*")

si par exemple ca se trouvait sur une autre feuille sur une colonne et qu'on la remplisse au fur et a mesure ca serait top; pensez vous que cela soit possible?

je vous remercie encore une fois de votre aide

Pierre

 

[ChTi160]

Bonjour le Fil
Il faudra alors remplir un Array(tableau) des valeurs présentes dans la Colonne source.
Ex

Dim Tableau
Dim DerLgn as intégrer
With Worksheets("Nom de la Feuille")
DerLgn = .Cells(.Rows.Count,1).End (XlUp).Row  (1) pour colonne A 
dans  Cells(.Rows.Count,1)
'On remplit le Tableau des Valeurs de la plage ainsi définie
Tableau= .Range(.Cells(1,1),.Cells(DerLgn,1)).Value
End With

Perfectible! Publié depuis mon téléphone
Jean marie

 

[TooFatBoy]

Bonjour,

Une proposition en pièce jointe, reprenant la macro de #3 de sylvanu.

Sub Nettoyage()
Dim Tablo, Liste, N%, i%, T0

    T0 = Timer                                                  ' Capture du temps initial
    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("")
    ReDim Preserve Liste(Range("t_Liste").Rows.Count)
    For N = 1 To Range("t_Liste").Rows.Count
        Liste(N) = "*" & Range("t_Liste")(N).Value & "*"
    Next N


    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

    Application.ScreenUpdating = True                           ' Retour des flags initiaux
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    [A1].Select
    MsgBox "Fini en " & Round(1000 * (Timer - T0), 0) & "ms"    ' Affichage du temps d'éxécution

End Sub