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
 
Solution
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

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
Repose en paix
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 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.
 

Discussions similaires

Réponses
11
Affichages
396