Comment accélérer mon code ?

[nak]

Bonjour,

Voici un code qui me permet de récupérer les données d'une base et d'ensuite supprimer les lignes de la base qui ne correspondent pas à mon filtre en F4.

Sub extractionValeurBase()
    Dim Source As ADODB.Connection
    Dim Rst As ADODB.Recordset
    Dim ADOCommand As ADODB.Command
    Dim Fichier As String, Cellule As String, Feuille As String
 
    'Adresse de la cellule contenant la donnée à rechercher
    Cellule = "A2:T"
 
    Feuille = "Feuil1$" 'n'oubliez pas d'ajouter $ au nom de la feuille.
    'Chemin complet du classeur fermé
    Fichier = ThisWorkbook.Path & "\base.xls"
 
    Set Source = New ADODB.Connection
    Source.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
        "Data Source=" & Fichier & ";Extended Properties=""Excel 8.0;HDR=No;"";"
 
    Set ADOCommand = New ADODB.Command
    With ADOCommand
        .ActiveConnection = Source
        .CommandText = "SELECT * FROM [" & Feuille & Cellule & "]"
    End With
 
    Set Rst = New ADODB.Recordset
    Rst.Open ADOCommand, , adOpenKeyset, adLockOptimistic
 
    Set Rst = Source.Execute("[" & Feuille & Cellule & "]")
 
    Range("A11").CopyFromRecordset Rst
 
    Rst.Close
    Source.Close
    Set Source = Nothing
    Set Rst = Nothing
    Set ADOCommand = Nothing
 
    Call supprimerOF
 
End Sub

Sub supprimerOF()
Dim i As Long, derligne As Long
derligne = Range("A65536").End(xlUp).Row
Application.ScreenUpdating = False
'Suppression des lignes inutiles
For i = derligne To 11 Step -1
If UCase(Range("B" & i).Value) <> UCase(Range("F4").Value) Then Rows(i).Delete
Next i
Application.ScreenUpdating = True
End Sub

Comment faire pour l'accélérer ? En sachant que le problème vient de la partie suppression.

Merci

 

[Yaloo]

Re : Comment accélérer mon code ?

Bonsoir Nak,

A première vue, un filtre sur les données de la colonne B, filtre excluant la valeur de la cellule F4, puis la suppression des lignes visibles et enfin enlever le filtre qui permet d'afficher toutes les lignes dont la colonne B correspond à la valeur de F4.

A te relire

Martial

 

[ROGER2327]

Re : Comment accélérer mon code ?

Bonsoir à tous.

On peut remplacer​

Application.ScreenUpdating = False

par :​

With Application: .ScreenUpdating = 0: .EnableEvents = 0: .Calculation = -4135: End With

et​

Application.ScreenUpdating = True

par :​

With Application: .Calculation = -4105: .EnableEvents = 1: .ScreenUpdating = 1: End With

Si le (ou les) classeur(s) ouvert(s) comportent des formules et des procédures évènementielles, le gain de temps peut être significatif.​

ROGER2327
#6466

Vendredi 27 Gueules 140 (Saint Tabagie, cosmogène - fête Suprême Quarte)
3 Ventôse An CCXXI, 9,2784h - violier
2013-W08-4T22:16:05Z

 

[nak]

Re : Comment accélérer mon code ?

Bonjour et merci pour vos réponses,

Malheureusement je n'ai aucune formule dans mon fichier et encore moins de procédure évènementielle.
Accélérer une boucle ne semble pas une chose facile.
L'idée du filtre semble bonne même si il me parait difficile de faire un filtre avec <> de.
Je vais essayer, je vous tiens au courant.

Encore merci.

A+

 

[Papou-net]

Re : Comment accélérer mon code ?

Bonjour nak, Yaloo, ROGER,

Une autre solution qui devrait être assez rapide :

Sub supprimerOF()
Dim Cel As Range, Plage As Range
'Suppression des lignes inutiles
For Each Cel In Range("B:B").SpecialCells(xlCellTypeConstants)
  If UCase(Cel.Value) <> UCase(Range("F4").Value) Then
    If Plage Is Nothing Then Set Plage = Cel Else Set Plage = Application.Union(Plage, Cel)
  End If
Next
Plage.Delete
End Sub

Cordialement.

 

[nak]

Re : Comment accélérer mon code ?

Bonjour Papou-net,

Ta solution semble bonne, par contre elle efface "seulement" les cellules qui sont différentes de F4.
Du coup je vais utiliser Plage.EntireRow.Delete
Je lance le test de rapidité !

Merci

A+

 

[nak]

Re : Comment accélérer mon code ?

Re,

C'est toujours vraiment trop long... J'attaque plusieurs dizaines de millier de lignes...

Je vais me replonger dans la méthode du filtre.
Le problème c'est que le code suivant ne fonctionne pas.

Criteria1:="<>" & Sheets("Feuil1").Range("F4").Value

Vous avez une idée pourquoi ?

Merci

 

[néné06]

Re : Comment accélérer mon code ?

Bonsoir le forum,

@Nak

Essayes ce petit exemple, fait par la méthode "Match", qui me semble assez rapide et dis-nous ?

A+

Rene

 

[ROGER2327]

Re : Comment accélérer mon code ?

Bonjour à tous

Un autre essai, toujours à l'aveugle faute de support.​

Sub supprimerOF()
Dim derLig&, derCol&, titre&, ref$
Dim i&, j&, k&, u(), v()
    titre = 10 'N° de la ligne d'intitulé des champs
    ref = UCase(Range("F4").Value)
    derLig = Cells(Rows.Count, 1).End(xlUp).Row
    derCol = Cells(titre, Columns.Count).End(xlToLeft).Column
    u = Cells(11, 1).Resize(derLig - titre, derCol).Value
    ReDim v(1 To derLig - titre, 1 To derCol)
    For i = 1 To UBound(u)
        If UCase(u(i, 2)) = ref Then
            k = k + 1
            For j = 1 To derCol: v(k, j) = u(i, j): Next
        End If
    Next i
    With Application: .ScreenUpdating = 0: .EnableEvents = 0: .Calculation = -4135: End With
    Cells(titre + 1, 1).Resize(derLig - titre, derCol).Value = v
    With Application: .Calculation = -4105: .EnableEvents = 1: .ScreenUpdating = 1: End With
End Sub

(Testé sur 50 000 lignes * 104 colonnes : ~13 secondes.)


ROGER2327
#6468

Samedi 28 Gueules 140 (Sainte Hylactor et Pamphagus - fête Suprême Quarte)
4 Ventôse An CCXXI, 7,2046h - troêne
2013-W08-5T17:17:28Z

 

[nak]

Re : Comment accélérer mon code ?

Bonsoir à tous,

Je viens de tester vos deux propositions.
Celui de Roger semble le plus rapide. Il est même incroyablement rapide à coté de ma boucle qui dure plusieurs minutes.

A mon avis ça va être très difficile de faire mieux à part peut être travailler sur l'importation mais ça c'est une autre histoire.

Je vous joins les fichiers d'essais pour vous faire une idée. Par contre il faut éditer le fichier base.xls pour lui ajouter 65000 lignes (c'était trop pour le forum ).

Merci beaucoup !

 

[néné06]

Re : Comment accélérer mon code ?

Bonsoir à tous,

J'ai pensé à une chose, si l'on souhaite accélérer ?

Pourquoi ne pas placer une colonne en index, faire le trie par le colonne "B", supprimer les lignes dont cellule "B" contient F4,et refaire un trie par les index ?

c'est peut-être une bêtise ,mais ??????

A+

rené

 

[néné06]

Re : Comment accélérer mon code ?

Re,

J'ai essayé par tri et match avec index et cela à l'air assez rapide !

Testez et dites-moi ?

A+

René

 

[nak]

Re : Comment accélérer mon code ?

Bravo René !

C'est encore plus rapide ! On gagne encore 30% de temps.
Par contre il doit avoir une petite erreur dans le code car le filtre oubli 1 ou 2 lignes suivant les choix F4.
J'essai de trouver le problème mais j'avoue que j'ai du mal à comprendre ton code

En tout cas félicitation pour cette prouesse ! Et merci !

 

[laurent950]

Re : Comment accélérer mon code ?

Bonsoir,

En feuille 1 les donner conserver coresponde a la cellule F4 ici j

le tableau est filtrer sur le colonne 2 du tableau et que les ligne s de la collone 2 correspondant a j sont conserver (j est variable en fonction de se que la cellule F4 est renseigné)

Pour info votre tableau d'origine est conserver est coller dans sont intégralité en Feuil 2

Voici le code

module 1 = filtre

Sub test()

Dim F As Worksheet
Set F = ThisWorkbook.Worksheets("Feuil1")
Dim F2 As Worksheet
Set F2 = ThisWorkbook.Worksheets("Feuil2")

' Valeur chercher F4 (Cellule)
Dim val As String
val = LCase(F.Cells(4, 6))

' Redimension du tableau
Dim tabVal()
tabVal = F.Range(F.Cells(10, 1), F.Cells(65536, 19).End(xlUp))
ReDim Preserve tabVal(1 To F.Cells(65536, 1).End(xlUp).Row - 9, 1 To 20)

' Suppression des données
F.Range(F.Cells(10, 1), F.Cells(65536, 19).End(xlUp)).Clear

' Partage du même tableau en mémoire avant modification
Dim tabValOrg()
tabValOrg = tabVal

' Traitement des données (Filtre sur la colonne 2 du tableau avec critére
' en Cellule F4
For i = 1 To UBound(tabVal, 1)
    If tabVal(i, 2) = val Then
        tabVal(i, 20) = val
    End If
Next i

' Compteur Pour Nouvelle dimenssion
Dim cpt As Double
cpt = 0
' Restitution des donnée
For i = 1 To UBound(tabVal, 1)
    If tabVal(i, 20) = val Then
        cpt = cpt + 1
            For j = 1 To 19
                tabVal(cpt, j) = tabVal(i, j)
            Next j
    End If
Next i

' Modification d'une instruction :
' Explication :
' Je colle ici avec ce code = UBound(tabVal, 2)
' 20 colonnes
' et je doit en faite coller que 19 colonnes
' soit avec la modif ici = UBound(tabVal, 2)-1
' Extraire le tableau
' de la premiere ligne du tableau a une ligne donnée
' exemple tableau de 1 a 500 ligne et cpt = la 230 éme ligne
' soit ligne 1 a 230 sur toute les colonnes du tableau
 'F.Cells(10, 1).Resize(cpt, UBound(tabVal, 2)).Value = tabVal
 F.Cells(10, 1).Resize(cpt, UBound(tabVal, 2) - 1).Value = tabVal

' Le tableau d'origine est sauvegarder "tabValOrg"
' il est recopier en entier sur sur la feuille 2:
 F2.Cells(10, 1).Resize(UBound(tabValOrg, 1), UBound(tabValOrg, 2)).Value = tabValOrg

Erase tabVal, tabValOrg
End Sub

Complement
module 2 = defiltres

Sub collerSauv()

Dim F2 As Worksheet
Set F2 = ThisWorkbook.Worksheets("Feuil2")
Dim F As Worksheet
Set F = ThisWorkbook.Worksheets("Feuil1")
F.Range(F.Cells(10, 1), F.Cells(65536, 19).End(xlUp)).clear

' Redimension du tableau
Dim tabValOrg()
tabValOrg = F2.Range(F2.Cells(10, 1), F2.Cells(65536, 19).End(xlUp))

' Le tableau d'origine est sauvegarder "tabValOrg"
' il est recopier en entier sur sur la feuille 2:

 F.Cells(10, 1).Resize(UBound(tabValOrg, 1), UBound(tabValOrg, 2)).Value = tabValOrg

End Sub

Ps : le bouton defiltre renvoie le tableau d'origine sur la feuille 1

Laurent

 

[Habitude]

Re : Comment accélérer mon code ?

bonjour à tous

Tu conserve ton code et tu remplace
Rows(i).Delete par Rows(i).ClearContents

Ensuite tu tri. Les lignes vide vont se retrouver à la fin.