Supression ligne suivant 2 critères contenus dans cellules - amélioration code vitesse

rcan7412

XLDnaute Occasionnel
Bonjour,

Etant loin d'être un pro du VBA, je souhaiterai avoir une procédure plus rapide pour exécuter le code suivant :


Code:
Sub EffacerlignesPériode()

Worksheets("ExportEcritures").Select
derniereligne = Columns("A:A").Find("*", Range("A1"), , , xlByRows, xlPrevious).Row
For I = derniereligne To 1 Step -1

If Cells(I, 1) <> "" And Cells(I, 1) < Range("Départ!e8").Value Or Cells(I, 1) > Range("Départ!e9").Value Then

Rows(I).Select
Selection.Delete Shift:=xlUp

End If
Next
End Sub
Le principe est d'effacer toute ligne d'une feuille excel sur base du contenu de la première colonne A.
Les critères variables sont contenus dans 2 cellules d'une autre feuille du classeur.

Critère 1 : 201601
Critère 2 : 201612

Toute ligne dont la valeur en colonne A est inférieure au critère 1 ou supérieure au critère 2 doit être effacée.

Le code ci-avant fonctionne mais est très lent. Il faut près de 5 minutes pour faire 20.000 enregistrements.

Si quelqu'un aurait la gentillesse de me proposer un code plus efficace ?

Rodolphe
 

pierrejean

XLDnaute Barbatruc
Bonjour Rodolphe

A tester:

Code:
Sub EffacerlignesPériode()
Worksheets("ExportEcritures").Select
derniereligne = Columns("A:A").Find("*", Range("A1"), , , xlByRows, xlPrevious).Row
ReDim tabli(0)
For I = derniereligne To 1 Step -1
If Cells(I, 1) <> "" And Cells(I, 1) < Range("Départ!e8").Value Or Cells(I, 1) > Range("Départ!e9").Value Then
tabli(UBound(tabli)) = I
ReDim Preserve tabli(UBound(tabli) + 1)
End If
Next
Application.ScreenUpdating = False
For n = 0 To UBound(tabli) - 1
  Rows(tabli(n)).Delete
Next
Application.ScreenUpdating = True
End Sub
 

mapomme

XLDnaute Barbatruc
Supporter XLD
Bonjour à tous,

Essayez:
VB:
Sub EffacerlignesPériode()
   Dim derlig&, premcolvide&, t, i, min, max, ti
   ti = Timer: Application.ScreenUpdating = False
   min = Range("Départ!e8"): max = Range("Départ!e9")
   With Worksheets("ExportEcritures")
      derlig = .Columns("A:A").Find("*", Range("A1"), , , xlByRows, xlPrevious).Row
      premcolvide = .UsedRange.Column + .UsedRange.Columns.Count
      t = .Range("a1:a" & derlig)
      For i = 1 To derlig
         t(i, 1) = IIf(t(i, 1) <> "" And (t(i, 1) < min Or t(i, 1) > max), CVErr(xlErrDiv0), Empty)
      Next i
      .Cells(1, premcolvide).Resize(derlig) = t
      .Range(.Cells(1, "a"), .Cells(derlig, premcolvide)).Sort key1:=.Cells(1, premcolvide)
      On Error Resume Next
      .Cells(1, premcolvide).Resize(derlig).SpecialCells(xlCellTypeConstants, xlErrors).EntireRow.Delete
   End With
   MsgBox Format(Timer - ti, "0.00\ sec.")
End Sub

edit: bonjour @pierrejean ;)
 
Dernière édition:

rcan7412

XLDnaute Occasionnel
Incroyable mapomme !!!!

Même pas une seconde ! Ah que j'admire les personnes qui savent manier du code ! Si seulement je pouvais déjà le comprendre ... :(
Pour me consoler, on va dire chacun sa spécialité. ;)

Merci à vous deux pour vos réponses. Ça faisait des heures que je faisais des recherches sur le net.
 

rcan7412

XLDnaute Occasionnel
Il me reste un problème avec ton code mapomme. :(
La finalité de mon application est un export en fichier CSV. J'ai une macro qui exporte le tableau avec les "" et les ,

Voici ce que je dois obtenir :

"201601","160001","0","D01","160001","201601","2016/01/08"
"201601","160001","1","D01","160001","1","S","","300","A-160001-LAMPIRIS E1600331213","-312,74"
"201601","160001","2","D01","160001","2","A","612021","","A-160001-LAMPIRIS E1600331213","219,64"
"201601","160001","3","D01","160001","3","A","612021","","A-160001-LAMPIRIS E1600331213","3,73"
"201601","160001","4","D01","160001","4","A","612011","","A-160001-LAMPIRIS E1600331213","35,24"
"201601","160001","5","D01","160001","5","A","612011","","A-160001-LAMPIRIS E1600331213","0,61"
"201601","160001","6","D01","160001","6","A","498100","","A-160001-LAMPIRIS E1600331213","46,12"
"201601","160001","7","D01","160001","7","A","498100","","A-160001-LAMPIRIS E1600331213","7,4"

Et voici ce j'obtiens après le traitement de ton code :

"201601","160001","0","D01","160001","201601","2016/01/08","","","","",""
"201601","160001","1","D01","160001","1","S","","300","A-160001-LAMPIRIS E1600331213","-312,74",""
"201601","160001","2","D01","160001","2","A","612021","","A-160001-LAMPIRIS E1600331213","219,64",""
"201601","160001","3","D01","160001","3","A","612021","","A-160001-LAMPIRIS E1600331213","3,73",""
"201601","160001","4","D01","160001","4","A","612011","","A-160001-LAMPIRIS E1600331213","35,24",""
"201601","160001","5","D01","160001","5","A","612011","","A-160001-LAMPIRIS E1600331213","0,61",""
"201601","160001","6","D01","160001","6","A","498100","","A-160001-LAMPIRIS E1600331213","46,12",""
"201601","160001","7","D01","160001","7","A","498100","","A-160001-LAMPIRIS E1600331213","7,4",""

Sur la ligne "0", il ajoute ceci : ,"","","","",""
Or sur cette ligne 0, je ne peux pas avoir ces champs à vide pour l'import dans le programme externe.

Peut-on trouver une explication ? Merci
 

rcan7412

XLDnaute Occasionnel
Juste pour info, le code pour l'export du csv :

Code:
Sub Export_ecritures_Octopus_formatage_CSV()
chemin = Range("Départ!f2").Value
MonFichier = Range("Départ!e3").Value
'chemin = ThisWorkbook.Path
'MonFichier = "Test.csv"
MonSep = ","
'--------------------------------
Worksheets("ExportEcritures").Select
Set fs = CreateObject("Scripting.FileSystemObject")
fs.CreateTextFile chemin & "\" & MonFichier
Set f = fs.GetFile(chemin & "\" & MonFichier)
Set ts = f.OpenAsTextStream(2, -2)
For Each X In ActiveSheet.Range("A1:" & ActiveSheet.Range("A65536").End(xlUp).Address)
    For Each Y In ActiveSheet.Range(X, ActiveSheet.Cells(X.Row, 256).End(xlToLeft))
        MaVar = MaVar & MonSep & """" & Y & """"
    Next
ts.Write Right(MaVar, Len(MaVar) - 1) & Chr(13) + Chr(10)
MaVar = ""
Next
ts.Close
End Sub
 

mapomme

XLDnaute Barbatruc
Supporter XLD
Bonsoir @rcan7412,

Je ne me suis pas penché sur votre cas avant ce soir. Ajouter à mon code, la ligne:
VB:
.Cells(1, premcolvide).clear
juste avant la ligne
VB:
End With

Je mets le code modifié et commenté:
VB:
Sub EffacerlignesPériode()
   Dim derLig&, premColVide&, t, i, min, max, valErreur, ti
   ti = Timer: Application.ScreenUpdating = False
   ' on stocke les deux bornes dans des variables et une variable contenant une erreur
   min = Range("Départ!e8"): max = Range("Départ!e9"): valErreur = CVErr(xlErrDiv0)
   With Worksheets("ExportEcritures")  'avec la feuille "ExportEcritures"
      'dernière ligne de la colonne A
      derLig = .Columns("A:A").Find("*", Range("A1"), , , xlByRows, xlPrevious).Row
      ' Première colonne non utilisée de la feuille
      ' UsedRange contient la plage utilisée de la feuille
      ' on considère la première colonne de cette zone (qui n'est pas toujours la colonne A)
      ' on y rajoute le nombre de colonne de cette zone pour obtenir la première colonne non utilisée
      premColVide = .UsedRange.Column + .UsedRange.Columns.Count
      ' transfert des valeurs de la colonne A dans un tableau t
      t = .Range("a1:a" & derLig)
      'pour chaque valeur du tableau t
      ' si elle répond aux conditions de suppression, on la remplace par une valeur d'erreur
      ' si elle ne répond pas aux conditions de suppression, on la remplace par vide
      For i = 1 To derLig
         t(i, 1) = IIf(t(i, 1) <> "" And (t(i, 1) < min Or t(i, 1) > max), valErreur, Empty)
      Next i
      ' on transfère les nouvelles valeurs du tableau t sur la feuille, dans la première
      ' colonne inutilisée
      .Cells(1, premColVide).Resize(derLig) = t
      ' on trie la feuille selon la dernière colonne (vide ou valeur d'erreur)
      .Range(.Cells(1, "a"), .Cells(derLig, premColVide)).Sort key1:=.Cells(1, premColVide)
      On Error Resume Next 'au cas où aucune ligne ne répondrait aux critères
      ' on demande de considérer les cellules de la dernière colonne ayant une valeur d'erreur
      ' (ces cellules sont contigües à cause du tri qu'on a fait) et on supprime les lignes
      ' entières de ce bloc de cellules
      .Cells(1, premColVide).Resize(derLig).SpecialCells(xlCellTypeConstants, xlErrors).EntireRow.Delete
      ' on efface la dernière colonne utilisée
      .Cells(1, premColVide).EntireColumn.Clear
   End With
   MsgBox Format(Timer - ti, "0.00\ sec.")
End Sub
 
Dernière édition:

rcan7412

XLDnaute Occasionnel
Bonjour Mapomme, merci pour votre réponse très complète et éducative en ce qui me concerne.

Hélàs le code
Code:
.Cells(1, premcolvide).clear
ne fonctionnera pas dans mon cas.
J'ai des lignes à longueur variables (4 colonnes et 8 colonnes).

Et ces lignes sont mélangées :

Code:
D01    170001    201701    2017/01/31               
D01    170001    1    S        94    A-170001-BORESLAUSCHI MIHAELA 8    241
D01    170001    2    A    610302        A-170001-BORESLAUSCHI MIHAELA 8    -227,36
D01    170001    3    A    498100        A-170001-BORESLAUSCHI MIHAELA 8    -13,64
D01    170002    201701    2017/01/26               
D01    170002    1    S        68    A-170002-MARTENS CONFECTIE 2503857    2811
D01    170002    2    A    604000        A-170002-MARTENS CONFECTIE 2503857    -2811
D01    170002    3    A    498100        A-170002-MARTENS CONFECTIE 2503857    -590,31
D01    170002    4    A    498015        A-170002-MARTENS CONFECTIE 2503857    590,31
 

pierrejean

XLDnaute Barbatruc
Re

en modifiant un tout petit peu la superbe macro de Sa pomme
(on utilise pour le tri une colonne insérée en A)

A tester

Code:
Sub EffacerlignesPériode_b()
   Dim derLig&, premColVide&, t, i, min, max, valErreur, ti
   ti = Timer: Application.ScreenUpdating = False
   ' on stocke les deux bornes dans des variables et une variable contenant une erreur
   min = Range("Départ!e8"): max = Range("Départ!e9"): valErreur = CVErr(xlErrDiv0)
   With Worksheets("ExportEcritures")  'avec la feuille "ExportEcritures"
      'dernière ligne de la colonne A
      derLig = .Columns("A:A").Find("*", Range("A1"), , , xlByRows, xlPrevious).Row
     'on insere une colonne avant la colonne A
      .Columns("A:A").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
      ' transfert des valeurs de la colonne A dans un tableau t
      t = .Range("B1:B" & derLig)
      'pour chaque valeur du tableau t
      ' si elle répond aux conditions de suppression, on la remplace par une valeur d'erreur
      ' si elle ne répond pas aux conditions de suppression, on la remplace par vide
      For i = 1 To derLig
         t(i, 1) = IIf(t(i, 1) <> "" And (t(i, 1) < min Or t(i, 1) > max), valErreur, Empty)
      Next i
      ' on transfère les nouvelles valeurs du tableau t sur la feuille, dans la première
      ' colonne
      .Cells(1, 1).Resize(derLig) = t
      ' on trie la feuille selon la  colonne A (vide ou valeur d'erreur)
      .Range(.Cells(1, "a"), .Cells(derLig, Columns.Count)).Sort key1:=.Cells(1, 1)
      On Error Resume Next 'au cas où aucune ligne ne répondrait aux critères
      ' on demande de considérer les cellules de la dernière colonne ayant une valeur d'erreur
      ' (ces cellules sont contigües à cause du tri qu'on a fait) et on supprime les lignes
      ' entières de ce bloc de cellules
      .Cells(1, 1).Resize(derLig).SpecialCells(xlCellTypeConstants, xlErrors).EntireRow.Delete
      ' on efface la dernière colonne utilisée
      .Cells(1, 1).EntireColumn.Delete
   End With
   MsgBox Format(Timer - ti, "0.00\ sec.")
End Sub
 

mapomme

XLDnaute Barbatruc
Supporter XLD
Bonjour @rcan7412, @pierrejean ;),

Merci beaucoup pierrejean :).

J'avais aussi pensé écrire:
.Range(.Cells(1, premColVide), .Cells(1, .Columns.Count)).EntireColumn.Delete
à la place de:
.Cells(1, premColVide).EntireColumn.Clear (à tester si un fichier exemple anonymisé avait été posté :))

ne fonctionnera pas dans mon cas.
J'ai des lignes à longueur variables (4 colonnes et 8 colonnes).
La colonne premColVide est la première colonne non utilisée. Elle est donc juste après la colonne 8 si la colonne 8 est la dernière colonne utilisée.
 
Dernière édition:

rcan7412

XLDnaute Occasionnel
Bonjour Pierrejean et mapomme,

Merci pour votre aide précieuse.

Je vous confirme que tous vos codes fonctionnent parfaitement. Mon message sur le nombre de colonne n'est pas adéquat.
Avant de réaliser la procédure que vous proposez, j'en avais lancé une autre qui efface les 3 premières colonnes.
Cette procédure doit être lancée après dans mon schmilblick.

Merci encore
 

Discussions similaires

Statistiques des forums

Discussions
311 720
Messages
2 081 897
Membres
101 833
dernier inscrit
sandra25