VBA : Supprimer 1 ligne sur 2

[LouisBlanc]

Bonjour à tous

J'ai 1 fichier de 54000 lignes et 5 colonnes.
Il faut que je supprime 1 ligne sur 2.
Je réussi à le faire dans une boucle for next

For i = 2 To nptotal + 1
Rows(i).Select
Selection.Delete Shift:=xlUp
Next

mais l'exécution est très longue.
Je souhaiterais faire une sélection multiple d'1 ligne sur 2 (à l'aide d'1 boucle peut être), puis supprimer la sélection en 1 seule opération, ce qui je pense gagnerait beaucoup en temps d'exécution.
Mais voilà, je n'arrive pas à faire cette sélection.
Auriez vous des propositions.

Merci d'avance

 

[Staple1600]

Re : VBA : Supprimer 1 ligne sur 2

Bonsoir à tous

Louis
Une solution possible (test OK ici)

Sub a()
Dim p As Range
Set p = Range([A1], [A65536].End(xlUp)) 'ici définit la plage de cellules utiles de la colonne A
Application.ScreenUpdating = False
With p.Offset(, 255) 'insére la formule en colonne IV (car test fait sur PC avec XL2003)
    .FormulaR1C1 = "=IF(MOD(ROW(),2)=0,1,"""")" ' la formule en question
    .Value = .Value ' simule le copie/colle -> Valeurs seules
    .SpecialCells(xlCellTypeConstants, 1).EntireRow.Delete 
' utilise SpecialCells pour sélectionner les lignes avec un valeur numérique
'en colonne IV et supprime ces lignes
End With
End Sub

 

[Gelinotte]

Re : VBA : Supprimer 1 ligne sur 2

Bonsoir,

Avec un gain de 2 secondes sur 60000 lignes

Sub testage()
Dim NpTotal As Double
Application.ScreenUpdating = False
NpTotal = Range("a65535").End(xlUp).Row
For i = 2 To NpTotal + 1
    Rows(i + 1).Delete
Next
End Sub

G

 

[LouisBlanc]

Re : VBA : Supprimer 1 ligne sur 2

Merci, mais ça efface tout.... et je ne comprends pas bien ton code. Peux tu mettre quelques commentaires

 

[Gelinotte]

Re : VBA : Supprimer 1 ligne sur 2

Allô!

C'est mon code qui de donne des sueurs ??

Sub testage()
Dim NpTotal As Double >> défini le format de la variable

Application.ScreenUpdating = False >> gèle l'affichage de l'écran pour accélérer le traitement.

NpTotal = Range("a65535").End(xlUp).Row >> trouve la dernière ligne

For i = 2 To NpTotal + 1 >> pour i = 2 jusqu'à la dernière ligne

Rows(i + 1).Delete >> Ligne I+1 pour supprimer une ligne sur deux.

Next >> boucle jusqu'à la dernière ligne

End Sub >> fin

+/- 2 minutes pour 60000 lignes

Le code de Staple1600 fonctionne aussi à merveille avec un temps semblable.


G

 

[LouisBlanc]

Re : VBA : Supprimer 1 ligne sur 2

Gelinotte.
C'était bon pour ton code.... même résultat qu'avec le mien.
C'est celui de staple16000 que je ne comprends pas entièrement....

With p.Offset(, 255) >> comprends pas
.FormulaR1C1 = "=IF(MOD(ROW(),2)=0,1,"""")" >>> ça OK
.Value = .Value >>>> comprends pas
.SpecialCells(xlCellTypeConstants, 1).EntireRow.Delete >>>> OK
End With

mais en plus chez moi il ne fonctionne pas, ça efface tout.

Mais je persiste à croire qu'une sélection multiple serait beaucoup plus rapide.

J'arrive à sélectionner plusieurs lignes et à les supprimer en une seule fois, mais je n'arrive pas à automatiser la sélection multiple avec une variable dans une boucle.

Exemple qui marche pour 3 sélections

Dim ligne2 As Range, ligne4 As Range, ligne6 As Range, meslignes As Range

Set ligne2 = Rows(2)
Set ligne4 = Rows(4)
Set ligne6 = Rows(6)
Set meslignes = Union(ligne2, ligne4, ligne6)
meslignes.Select
Selection.Delete

Des idées ??

 

[Staple1600]

Re : VBA : Supprimer 1 ligne sur 2

Re


Une autre piste (avec le filtre élaboré) qui malheureusement échoue avec un grand nombre de lignes
(mais comme j'ai passé du temps dessus je poste)
(Ce test fonctionne sur mon PC, au delà de 16000 les problèmes arrivent )

Sub testFE()
Dim td&, tf
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
gd 16250, 5 'crée une plage de 16250 lignes x 5 colonnes
Application.ScreenUpdating = True
MsgBox "Supprimer une ligne sur deux?", 64, "TEST"
td = Timer
'filtre puis copie sur une autre feuille avec le filtre élaboré
Range("H2").FormulaR1C1 = "=RC[-2]=1"
Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Range("H1:H2"), Unique:=False
[_FilterDataBase].Resize(, 5).SpecialCells(12).Copy
Sheets("Feuil2").Select
Sheets("Feuil2").Range("A1").Select
ActiveSheet.Paste
tf = Timer - td: MsgBox tf: Sheets("Feuil1").ShowAllData
End Sub

Private Sub gd(nbl&, nbc&) 'juste pour créer de quoi faire le test
Dim p As Range, td&, tf
Cells.Clear: Set p = [A1]
p.Resize(2) = Application.Transpose(Array("LIGNE A GARDER", "LIGNE A EFFACER"))
p.Resize(2).AutoFill Destination:=p.Resize(nbl), Type:=xlFillDefault
p.Offset(, 1).Resize(nbl, nbc - 1).FormulaLocal = "=(LIGNE()*MAINTENANT())/ALEA()"
p.Offset(, nbc).Resize(nbl).FormulaR1C1 = "=MOD(ROW(),2)"
p.Columns.AutoFit: p.CurrentRegion.Value = p.CurrentRegion.Value
End Sub

NB: Louis, j'avais bien précisé

Une solution possible (test OK ici)

Je confirme que le code de mon premier message fonctionne.

 

[Staple1600]

Re : VBA : Supprimer 1 ligne sur 2

Re


Pour finir c'est la boucle qui semble la plus rapide (voir exemples sur le net à ce sujet)
Bonne nuit à tous et à plus dans la Cellule

Sub Lance_Test()
CREE_DATAS_POUR_TEST
MsgBox "Supprimer une ligne sur 2?", 64, "SUPPRESSION"
SUPPR_1LS2
End Sub

Private Sub CREE_DATAS_POUR_TEST()
[A1] = "GARDER": [A2] = "EFFACER"
[A1:A2].AutoFill Destination:=Range("A1:A31234"), Type:=xlFillDefault
End Sub

Private Sub SUPPR_1LS2()
Dim dl As Long, x As Long, dt&, ft&
dl = Cells(Cells.Rows.Count, 1).End(xlUp).Row
Application.ScreenUpdating = False
dt = Timer
For x = dl To 1 Step -1
    If Rows(x).Row Mod 2 = 0 Then
    Rows(x).EntireRow.Delete
    End If
Next
ft = Timer - dt: MsgBox ft
End Sub

 

[mapomme]

Re : VBA : Supprimer 1 ligne sur 2

Bonjour à tous,

Une autre méthode assez rapide basée sur une formule + un tri (fichier issu d'excel 2010 converti en 2003):

Sub SuppLigne1sur2()
Dim p As Range, q As Range, C, R
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
  Set p = UsedRange
  C = p.Column + p.Columns.Count
  If C > Columns.Count Then
    MsgBox "Pas de colonne dispo à droite de la feuille -> échec de la méthode"
    Exit Sub
  End If
  R = Cells(Rows.Count, 1).End(xlUp).Row
  If R = 1 And Cells(1, 1) = "" Then Exit Sub
  Set p = Range(Cells(1, 1), Cells(R, C))
  Set q = Range(Cells(1, C), Cells(R, C))
  q.Formula = "=IF(ISODD(ROW()),""a"",ROW())"
  q.Calculate
  q.Value = q.Value
  p.Sort key1:=Cells(1, C), Order1:=xlAscending, Header:=xlNo
  On Error Resume Next
  Range(q.Find(what:="a"), Cells(R, C)).EntireRow.Delete
  q.EntireColumn.Delete
  Application.ScreenUpdating = True
  Application.Calculation = xlCalculationAutomatic
End Sub

 

[Staple1600]

Re : VBA : Supprimer 1 ligne sur 2

Bonjour mapomme

Bah mince alors, je venais de me réveiller avec la même idée

Merci mapomme, je vais pouvoir petitdéjeuner sans avoir le nez dans vbe

PS:mapomme
Dans mon idée que j'ai, je voyais un =Empty plutôt qu'un EntireRow.Delete (cf le code dans mon premier message)
.SpecialCells(xlCellTypeConstants, 1).EntireRow=Empty
puis le tri ensuite
Que penses-tu qui soit le plus rapide?
Remplir des lignes de vide ou supprimer des lignes qui ne le sont pas vide ?

 

[mapomme]

Re : VBA : Supprimer 1 ligne sur 2

Bonjour LouisBlanc, Staple1600 , à tous,

Remplir des lignes de vide ou supprimer des lignes qui ne le sont pas vide ?

Ta question m'a mis sur une autre voie. Utiliser un tableau pour réduire au maximum les opérations sur la feuille. Je n'utilise donc plus de formule. Effectivement, c'est un peu plus rapide...[/QUOTE]

Sub SuppLigne1sur2_v2()
Dim p As Range, N, M, Q, i As Long
Dim T1 As Single
  T1 = Timer
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
  'zone dela colonne
  Set p = Range(Range("A1"), Cells(Rows.Count, 1).End(xlUp))
  ' N --> n° dernière ligne remplie de la colonne A
  N = p.Rows.Count
  ' si N =1 et si A1 est vide --> on ne fait rien
  If N = 1 And Range("a1") = "" Then Exit Sub
  ' déclaration du tabeau Q
  ReDim Q(1 To N)
  For i = 2 To N Step 2
    Q(i) = 1      '1 pour conserver la ligne
  Next i
  '1ere colonne vide à droite
  M = UsedRange.Column + UsedRange.Columns.Count
  If M > Columns.Count Then
    ' s'il n'y a pas de colonne vide --> on quitte
    MsgBox "Pas de colonne dispo à droite de la feuille -> échec de la méthode"
    Exit Sub
  End If
  ' Transfert su tableau Q dans la colonne n° M
  Cells(1, M).Resize(N).Value = Application.Transpose(Q)
  ' tri de la colonne n° M
  Range(Range("A1"), Cells(N, M)).Sort key1:=Cells(1, M), Order1:=xlAscending, Header:=xlNo
  ' suppression des lignes
  Range(Cells(1 + N \ 2, M), Cells(N, M)).EntireRow.Delete
  ' effacement de la colonne n° M
  Columns(M).ClearContents
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationAutomatic
  MsgBox Format(Timer - T1, "0.000 s")
End Sub

 

[job75]

Re : VBA : Supprimer 1 ligne sur 2

Bonjour à tous,

Sub SupprimeLignesPaires()
Dim t#, P As Range
t = Timer
Set P = ActiveSheet.UsedRange
If P.Rows.Count Mod 2 = 1 Then _
  Set P = P.Resize(P.Rows.Count + 1) 'nombre pair des lignes
P.Columns(1).Insert xlToRight 'colonne auxiliaire
P(1, 0) = 1: P(2, 0) = "a" 'un nombre, un texte
P(1, 0).Resize(2).Copy P(1, 0).Resize(P.Rows.Count) 'remplit la colonne
With P(1, 0).Resize(P.Rows.Count, P.Columns.Count + 1)
  .Sort P(1, 0), xlAscending 'le tri met les "a" en bas
  .Columns(1).SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete
  .Columns(1).Delete xlToLeft 'supprime la colonne auxiliaire
End With
MsgBox "Durée " & Format(Timer - t, "0.00 \s")
End Sub

Testée sur 60000 lignes => 0,27 seconde sur Win Xp/Excel 2003

A+

 

[Staple1600]

Re : VBA : Supprimer 1 ligne sur 2

Re à tous

Je reste avec ma question
Bon bah, m'en vais y répondre tout seul dans VBE après le fromage

PS: Bravo à tous deux pour jolis codes

 

[Gelinotte]

Re : VBA : Supprimer 1 ligne sur 2

Bonjour,

Sur la même machine, avec le code de Job75 pour 60000 lignes, on passe de +/- 2 minutes à +- 0.7 secondes.

C'est un léger gain qui devrait, je l'espère, satisfaire LouisBlanc.


G

 

[Gelinotte]

Re : VBA : Supprimer 1 ligne sur 2

Bonjour Staple1600,

Avec ton changement, (empty au lieu de delete). Pour 60000 lignes, je passe de +/- 2 minutes à 41 secondes.

C'est un excelent gain de temps, même si cela ne bas pas Speedy Gonzalez.


G