XL 2016 Delete shift:=xlUp trop long

sebastien450 · 21 Janvier 2020

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

job75 · 30 Janvier 2020

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"

sylvanu · 21 Janvier 2020

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 · 21 Janvier 2020

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😀VH6, D10😀VH10")...

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😀VH6").Find(cible, Range("D6"))
If rg Is Nothing Then
Else
Sheets("Feuil1").Rows(x & ":" & x).Delete shift:=xlUp
End If
Next x

sylvanu · 21 Janvier 2020

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 · 21 Janvier 2020

Bonjour,

Suppression de lignes rapide:

http://boisgontierjacques.free.fr/fichiers/Cellules/SupLignesRapide.xls

-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 · 24 Janvier 2020

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😀VH6,D14😀VH14,D22😀VH22,D30😀VH30,D38😀VH38,D46😀VH46,D54😀VH54,D62😀VH62,D70😀VH70,D78😀VH78,D86😀VH86,D94😀VH94,D102😀VH102,D110😀VH110,D118😀VH118,D126😀VH126,D134😀VH134,D142😀VH142,D150😀VH150,D158😀VH158,D166😀VH166").Find(cible)
If rg Is Nothing Then
Else
Sheets("Feuil1").Rows(x & ":" & x).Delete shift:=xlUp
End If
Next x

job75 · 24 Janvier 2020

Bonjour à tous,

sebastien450 à dit:
Ci-dessous mon code

Tous mdr 😀🙄

job75 · 24 Janvier 2020

@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 · 24 Janvier 2020

Merci je regarde cela dés que possible !

sebastien450 · 29 Janvier 2020

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 · 29 Janvier 2020

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 · 30 Janvier 2020

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 · 30 Janvier 2020

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.

job75 · 30 Janvier 2020

En cas de besoin voyez le fichier joint.

sebastien450 · 30 Janvier 2020

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😀VH6,D14😀VH14,D22😀VH22,D30😀VH30,D38😀VH38,D46😀VH46,D54😀VH54,D62😀VH62,D70😀VH70,D78😀VH78,D86😀VH86,D94😀VH94,D102😀VH102,D110😀VH110,D118😀VH118,D126😀VH126,D134😀VH134,D142😀VH142,D150😀VH150,D158😀VH158,D166😀VH166")
d(c.Value) = ""
Next
For Each c In Sheets("PLANNING").Range("D174😀VH174,D182😀VH182,D190😀VH190,D198😀VH198,D206😀VH206,D214😀VH214")
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.

XL 2016 Delete shift:=xlUp trop long

sebastien450

XLDnaute Occasionnel

job75

sylvanu

XLDnaute Barbatruc

sebastien450

XLDnaute Occasionnel

sylvanu

XLDnaute Barbatruc

BOISGONTIER

XLDnaute Barbatruc

sebastien450

XLDnaute Occasionnel

job75

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

sebastien450

XLDnaute Occasionnel

sebastien450

XLDnaute Occasionnel

job75

XLDnaute Barbatruc

sebastien450

XLDnaute Occasionnel

job75

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Pièces jointes

sebastien450

XLDnaute Occasionnel

Discussions similaires

XL 2016 Delete shift:=xlUp trop long

XLDnaute Occasionnel

XLDnaute Barbatruc

XLDnaute Occasionnel

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Occasionnel

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Occasionnel

XLDnaute Occasionnel

XLDnaute Barbatruc

XLDnaute Occasionnel

XLDnaute Barbatruc

XLDnaute Barbatruc

Pièces jointes

XLDnaute Occasionnel

Discussions similaires

Privacy & Transparency

Privacy & Transparency