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

R

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
 
Trier par date Trier par votes
pierrejean

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
 
Vote positif 0 Vote négatif
mapomme

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:
Vote positif 0 Vote négatif
R

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.
 
Vote positif 0 Vote négatif
R

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"
Cliquez pour agrandir...

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",""
Cliquez pour agrandir...

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
 
Vote positif 0 Vote négatif
R

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
 
Vote positif 0 Vote négatif
mapomme

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:
Vote positif 0 Vote négatif
R

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
 
Vote positif 0 Vote négatif
pierrejean

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
 
Vote positif 0 Vote négatif
mapomme

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é :))

rcan7412 à dit:
ne fonctionnera pas dans mon cas.
J'ai des lignes à longueur variables (4 colonnes et 8 colonnes).
Cliquez pour agrandir...
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:
Vote positif 0 Vote négatif
R

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
 
Vote positif 0 Vote négatif

Discussions similaires

G
  • Résolu(e)
XL 2021 VBA dates au mauvais format
Réponses
5
Affichages
200
vgendron
vgendron
A
  • Question
Microsoft 365 Code VBA Envoi contenu tableau Excel par Email
Réponses
1
Affichages
312
Phil69970
Phil69970
B
  • Question
XL 2013 Comment trier les nom des feuilles et fusionner leur tableaux dans une une autre feuille ?
Réponses
10
Affichages
483
Compte Supprimé 979
C
G
  • Question
Microsoft 365 Saut de ligne dans une cellule
Réponses
3
Affichages
416
GClaire
G
C
  • Question
Autres bug sur une procédure avec textbox contenant un code barre
2
Réponses
15
Affichages
1 K
TooFatBoy
TooFatBoy
M
  • Résolu(e)
Microsoft 365 Sélection ligne dans ListBox avec boutons précédent-suivant
4 5 6
Réponses
88
Affichages
4 K
meyscal
M
A
  • Question
XL 2019 Vérifier si une ligne existe dans un autre fichier
Réponses
7
Affichages
625
A-F
A
oguruma
POWERQUERY :: Importer un fichier .csv avec construction de critères dynamiques (5 max) de type texte et sélection entre deux dates possible - V2.0
Réponses
0
Affichages
274
oguruma
oguruma
C
  • Question
XL 2019 Tableau- creation de lignes: probleme de hauteur de lignes
Réponses
6
Affichages
563
Cheyenne_2021
C
A
  • Question
Microsoft 365 VBA code pour inserer des lignes une condition
Réponses
4
Affichages
691
AEz
A

Membres actuellement en ligne

3 membres et 552 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
314 499
Messages
2 110 248
Membres
110 711
dernier inscrit
chmessi