Résolu XL 2016 Delete shift:=xlUp trop long

sebastien450

XLDnaute Occasionnel
Bonjour,
Plus novice dans les macros je bloque pour optimiser le temps de traitement du code suivant
Sheets("Feuil1").Range(Cells(x, 1), Cells(x, 20)).Delete shift:=xlUp

Le delete est trop long - il est situé dans une boucle find qui est bien rapide testée seule.
Je précise que je cherche bien une autre écriture de ce code, peut être sans sélection de la ligne entière ?

A vos idées
 
Ce fil a été résolu! Aller à la solution…

sylvanu

XLDnaute Barbatruc
Supporter XLD
Bonjour Sébastien,
Si vous voulez supprimer une ligne complète, essayez ça pour voir si c'est plus rapide :
VB:
Ligne = 20  ' Numéro de ligne à supprimer
'
Sheets("Feuil1").Rows(Ligne & ":" & Ligne).Delete Shift:=xlUp
et s'il y a beaucoup de lignes à supprimer, n'oubliez surtout pas en début de macro de figer l'écran :
Code:
Application.ScreenUpdating = false
 

sebastien450

XLDnaute Occasionnel
Bonjour,
J'ai déja essayé mais aprés vérification il semble qu'il n'existe pas plus rapide.

A vrai dire je gagnerais du temps à limiter mon champs de recherche
Hors j'applique plusieurs fois la macro suivante car je n'arrive pas à faire la méthode find sur plusieurs range ("D6:DVH6, D10:DVH10")...

For x = nblig To 1 Step -1 'de 1 à champs des ofs
cible = Worksheets("Feuil1").Cells(x, 1).Value
Set rg = Worksheets("PLANNING").Range("D6:DVH6").Find(cible, Range("D6"))
If rg Is Nothing Then
Else
Sheets("Feuil1").Rows(x & ":" & x).Delete shift:=xlUp
End If
Next x
 

sylvanu

XLDnaute Barbatruc
Supporter XLD
Si vous savez que dans vos fichiers il y a statisquement beaucoup de chances que des lignes adjacentes soient à supprimer, vous pouvez faire plus rapide ... mais plus complexe.
Rechercher la premire ligne à supprimer (x), continuer jusqu'à la premire ligne à ne pas supprimer (y) puis supprimer les lignes de x à (y-1)
Je pense que c'est le même temps de supprimer une ligne ou plusieurs.
 

BOISGONTIER

XLDnaute Barbatruc
Bonjour,


Suppression de lignes rapide:

-on repère les lignes à supprimer avec la valeur Sup
-on tri les lignes . Les lignes contenant Sup se retrouvent à la fin
-on supprime les lignes contenant Sup

VB:
Sub supLignesRapide2()  0,15 sec pour 20.000 lignes
  Application.ScreenUpdating = False
  a = Range("A2:A" & [A65000].End(xlUp).Row)
  For i = LBound(a) To UBound(a)
    If a(i, 1) <> "xxxx" Then a(i, 1) = 0 Else a(i, 1) = "sup"
  Next i
  Columns("b:b").Insert Shift:=xlToRight
  [B2].Resize(UBound(a)) = a
  [A2].CurrentRegion.Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess
  On Error Resume Next
  Range("B2:B65000").SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete
  Columns("b:b").Delete Shift:=xlToLeft
End Sub

Boisgontier
 

sebastien450

XLDnaute Occasionnel
Boisgontier,
Ci-dessous mon code,
J'avoue ne pas réussir à transposer le tient aisément


nblig = Worksheets("Feuil1").Range("A1").End(xlDown).Row
For x = nblig To 1 Step -1 'de 1 à champs des ofs
cible = Worksheets("Feuil1").Cells(x, 1).Value
Set rg = Worksheets("PLANNING").Range("D6:DVH6,D14:DVH14,D22:DVH22,D30:DVH30,D38:DVH38,D46:DVH46,D54:DVH54,D62:DVH62,D70:DVH70,D78:DVH78,D86:DVH86,D94:DVH94,D102:DVH102,D110:DVH110,D118:DVH118,D126:DVH126,D134:DVH134,D142:DVH142,D150:DVH150,D158:DVH158,D166:DVH166").Find(cible)
If rg Is Nothing Then
Else
Sheets("Feuil1").Rows(x & ":" & x).Delete shift:=xlUp
End If
Next x
 

job75

XLDnaute Barbatruc
@sebastien450 cette macro devrait vous satisfaire :
VB:
Sub Supprimer()
Dim d As Object, c As Range, a, i&
'---liste sans doublon---
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For Each c In Sheets("PLANNING").Range("D6:DVH6,D14:DVH14,D22:DVH22,D30:DVH30,D38:DVH38,D46:DVH46,D54:DVH54,D62:DVH62,D70:DVH70,D78:DVH78,D86:DVH86,D94:DVH94,D102:DVH102,D110:DVH110,D118:DVH118,D126:DVH126,D134:DVH134,D142:DVH142,D150:DVH150,D158:DVH158,D166:DVH166")
    d(c.Value) = ""
Next
'---suppressions en Feuil1---
With Sheets("Feuil1").UsedRange
    a = .Columns(1).Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
    For i = 1 To UBound(a)
        a(i, 1) = IIf(d.exists(a(i, 1)), "sup", 0)
    Next
    Application.ScreenUpdating = False
    .Columns(1).Insert xlToRight 'insère une colonne auxiliaire
    .Columns(0) = a
    .EntireRow.Sort .Columns(0), xlAscending, Header:=xlNo 'tri pour regrouper et accélérer
    On Error Resume Next 'si aucune SpecialCell
    .Columns(0).SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete
    .Columns(0).Delete xlToLeft 'supprime la colonne auxiliaire
End With
End Sub
 

sebastien450

XLDnaute Occasionnel
Bonjour,
Malheuresement le code ne marche pas car il s'agit d'un tableau et le fait d'ajouter une ligne en colonne A ne permet pas de créer de filtre avec le tableau B:M
 

job75

XLDnaute Barbatruc
Bonjour sebastien450,

Vous vous réveillez, mais que vient faire le filtre dans cette affaire ?

Le problème posé est de supprimer rapidement des lignes, un point c'est tout.

A+
 

sebastien450

XLDnaute Occasionnel
Bonjour Job,

C'est sur cette ligne que bloque la macro
.EntireRow.Sort .Columns(0), xlAscending, Header:=xlNo
J'ai essayé de regrouper autrement des lignes à supprimer, mais alors je bloque sur le point suivant
.Columns(0).SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete
 

job75

XLDnaute Barbatruc
Bonjour sebastien450, le forum,

La macro de mon post #8 ne doit pas avoir été modifiée, sauf adaptation du nom des feuilles.

Par ailleurs la feuille où doit se faire la suppression (Feuil1) ne doit pas être filtrée ni protégée bien sûr.

Autre contrainte : pour que le tri fonctionne il ne faut pas de cellules fusionnées.

Bonne journée.
 

sebastien450

XLDnaute Occasionnel
Merci de mon aide,
J'ai réussi avec la code suivant
Dim d As Object, c As Range, a, j&
'---liste sans doublon---
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For Each c In Sheets("PLANNING").Range("D6:DVH6,D14:DVH14,D22:DVH22,D30:DVH30,D38:DVH38,D46:DVH46,D54:DVH54,D62:DVH62,D70:DVH70,D78:DVH78,D86:DVH86,D94:DVH94,D102:DVH102,D110:DVH110,D118:DVH118,D126:DVH126,D134:DVH134,D142:DVH142,D150:DVH150,D158:DVH158,D166:DVH166")
d(c.Value) = ""
Next
For Each c In Sheets("PLANNING").Range("D174:DVH174,D182:DVH182,D190:DVH190,D198:DVH198,D206:DVH206,D214:DVH214")
d(c.Value) = ""
Next
'---suppressions en Feuil1---
With Sheets("Feuil1").UsedRange
a = .Columns(1).Resize(, 1) 'matrice, plus rapide, au moins 2 éléments
For j = 1 To UBound(a)
a(j, 1) = IIf(d.exists(a(j, 1)), "sup", 0)
Next
Application.ScreenUpdating = False
Sheets("Feuil1").Columns("b:b").Insert Shift:=xlToRight 'insère une colonne auxiliaire
.Columns(2) = a
ActiveWorkbook.Worksheets("Feuil1").ListObjects("Tableau1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Feuil1").ListObjects("Tableau1").Sort.SortFields.Add Key:=Range("Tableau1[[#All],[0]]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Feuil1").ListObjects("Tableau1").Sort
.SortMethod = xlPinYin
.Apply
End With
On Error Resume Next 'si aucune SpecialCell
Sheets("Feuil1").Range("B2:B65000").SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete
Sheets("Feuil1").Columns("b:b").Delete Shift:=xlToLeft

A présent je regarde pour update mon listbox car il ne se met pas à jour immédiatement, je suis obligé de descendre tout en bas puis remonter la scrollbar.
 

job75

XLDnaute Barbatruc
Vous auriez pu nous dire dès le début que le tableau en Feuil1 était un tableau structuré.

Alors utilisez cette macro :
VB:
Sub Supprimer()
Dim d As Object, c As Range, a, i&
'---liste sans doublon---
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For Each c In Sheets("PLANNING").Range("D6:DVH6,D14:DVH14,D22:DVH22,D30:DVH30,D38:DVH38,D46:DVH46,D54:DVH54,D62:DVH62,D70:DVH70,D78:DVH78,D86:DVH86,D94:DVH94,D102:DVH102,D110:DVH110,D118:DVH118,D126:DVH126,D134:DVH134,D142:DVH142,D150:DVH150,D158:DVH158,D166:DVH166")
    d(c.Value) = ""
Next
For Each c In Sheets("PLANNING").Range("D174:DVH174,D182:DVH182,D190:DVH190,D198:DVH198,D206:DVH206,D214:DVH214")
d(c.Value) = ""
Next
'---suppressions en Feuil1---
With Sheets("Feuil1").ListObjects(1).Range
    a = .Columns(1).Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
    For i = 1 To UBound(a)
        a(i, 1) = IIf(d.exists(a(i, 1)), "sup", 0)
    Next
    Application.ScreenUpdating = False
    .Columns(2).Insert xlToRight 'insère une colonne auxiliaire
    .Columns(2) = a
    .Sort .Columns(2), xlAscending, Header:=xlYes 'tri pour regrouper et accélérer
    On Error Resume Next 'si aucune SpecialCell
    .Columns(2).Offset(1).SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete 'Offset(1) évite les en-têtes
    .Columns(2).Delete xlToLeft 'supprime la colonne auxiliaire
    With .Parent.UsedRange: End With 'actualise la barre de défilement verticale
End With
End Sub
J'ai ajouté une ligne pour actualiser la barre de défilement verticale.

Fichier (2), les lignes sont supprimées sans problème.
 
Ce message a été identifié comme étant une solution!

Fichiers joints

sebastien450

XLDnaute Occasionnel
Merci,
En effet j'ai oublié pour le tableau.
D’où l'utilité de fournir un fichier.
Malheureusement l'actualisation de la barre de défilement ne marche pas.
Le fait que mon tableau est ensuite utilisé en row.source dans un userform doit y être pour quelque chose.
je te joint le fichier tu comprendra mieux.
J'ai desactivé les éléments inutiles
 

Fichiers joints

job75

XLDnaute Barbatruc
Ouvrir UserForm2 par double-clic n'importe où dans la feuille PLANNING n'est pas bien fameux.

Dans la macro BeforeDoubleClick mettre Application.EnableEvents = False encore moins !!!

Et mettre ma macro dans UserForm_Initialize est une idée curieuse mais bof.

Ceci dit mon code supprime 3 lignes dans Feuil1 et la barre de défilement s'actualise parfaitement.

En effet au départ la dernière ligne est la ligne 45, ensuite c'est la ligne 42.

Maintenant s'il y a d'autres problèmes ce n'est plus le sujet de ce fil, ouvrez une autre discussion, c'est ce que préconise la Charte du forum.
 

job75

XLDnaute Barbatruc
Bon je comprends que ce qui vous embête c'est que la ListBox ne se met pas à jour.

Alors c'est bien simple, à la fin de la macro UserForm_Initialize ajoutez ces 2 instructions :
VB:
ListBox3.RowSource = ""
ListBox3.RowSource = "maliste"
 
Ce message a été identifié comme étant une solution!

Créez un compte ou connectez vous pour répondre

Vous devez être membre afin de pouvoir répondre ici

Créer un compte

Créez un compte Excel Downloads. C'est simple!

Connexion

Vous avez déjà un compte? Connectez vous ici.

Haut Bas