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

 

[job75]

Re : VBA : Supprimer 1 ligne sur 2

Re,

Avec Application.ScreenUpdating et AutoFill on gagnera quelques dixièmes de seconde :

Sub SupprimeLignesPaires()
Dim t#, P As Range
t = Timer
Application.ScreenUpdating = False
Set P = ActiveSheet.UsedRange
P.Columns(1).Insert xlToRight 'colonne auxiliaire
P(1, 0) = 1: P(2, 0) = "a" 'un nombre, un texte
P(1, 0).Resize(2).AutoFill P(1, 0).Resize(P.Rows.Count), xlFillValues
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

Edit : avec AutoFill plus besoin de se soucier de la parité du nombre de lignes.

A+

 

[mapomme]

Re : VBA : Supprimer 1 ligne sur 2

Bonjour à tous,

En lisant le code de job75, je me suis aperçu que je supprimais les lignes impaires et non paires (encore mal lu l'énoncé) 😡
Voici la correction.

 

[LouisBlanc]

Re : VBA : Supprimer 1 ligne sur 2

Bonjour à tous et merci

A la bourre et couché très tard, je n'ai pas le temps de tester vos propositions.

Par contre, avant d'éteindre le PC, j'avais trouvé une solution de secours qui résout en grande partie mon problème.

Je crée une variable tableau dans lequel je copie toutes mes données (c'est un tableau de 57600 lignes et 5 colonne qui commence en cellule A19).

Ensuite je crée une feuille de travail et je copie du tableau 1 ligne sur 2

Ensuite me reste à supprimer la feuille de départ et à renommer celle ci.

Voila, c'est une solution de secours, assez rapide..... et l'idée peut servir à d'autres.

Dès que je peux je teste vos propositions.
Merci encore.

Ci dessous mon morceau de code.


Dim tab_exemple()
ReDim tab_exemple(nbligne, nbcolonne)

'Enregistrement des valeurs dans le tableau
tab_exemple = Range(Cells(19, 1), Cells(nbligne + 19, nbcolonne)).Value


'création d'une feuille de travail
Sheets.Add
ActiveSheet.Name = "travail"

For i = 1 To NpTotal
Cells(i, 1) = tab_exemple((i * 2) - 1, 1)
Cells(i, 2) = tab_exemple((i * 2) - 1, 2)
Cells(i, 3) = tab_exemple((i * 2) - 1, 3)
Cells(i, 4) = tab_exemple((i * 2) - 1, 4)
Cells(i, 5) = tab_exemple((i * 2) - 1, 5)
Next

 

[MJ13]

Re : VBA : Supprimer 1 ligne sur 2

Bonjour à tous

Bizarre, je n'ai pas vu de fichier de la part de Louis 😕.

Le problème vient peut-être de la 🙂.

 

[laetitia90]

Re : VBA : Supprimer 1 ligne sur 2

bonjour tous 🙂🙂🙂🙂🙂🙂🙂
un autre exemple si il a 5 colonnes contigues & uniquement cela le code peut être plus simple mais pas forcement le plus rapide pas teste

Sub es()
 Dim t(), t1(), x As Long, i As Long, y As Long
 t = Range("a1:e" & Cells(Rows.Count, 1).End(xlUp).Row)
 ReDim t1(1 To UBound(t), 1 To 5)
 For i = 1 To UBound(t) Step 2
  x = x + 1
 For y = 1 To 5: t1(x, y) = t(i, y): Next y
 Next i
 Cells.ClearContents: Range("a1").Resize(x, 5) = t1
End Sub

 

[LouisBlanc]

Re : VBA : Supprimer 1 ligne sur 2

Ci dessous mon bout de code par rapport au message précédent

sub essai()

Dim tab_exemple()
ReDim tab_exemple(nbligne, nbcolonne)

'Enregistrement des valeurs dans le tableau
tab_exemple = Range(Cells(19, 1), Cells(nbligne + 19, nbcolonne)).Value


'création d'une feuille de travail
Sheets.Add
ActiveSheet.Name = "travail"

For i = 1 To NpTotal
Cells(i, 1) = tab_exemple((i * 2) - 1, 1)
Cells(i, 2) = tab_exemple((i * 2) - 1, 2)
Cells(i, 3) = tab_exemple((i * 2) - 1, 3)
Cells(i, 4) = tab_exemple((i * 2) - 1, 4)
Cells(i, 5) = tab_exemple((i * 2) - 1, 5)
Next

end sub

 

[job75]

Re : VBA : Supprimer 1 ligne sur 2

Re,

Plus simple en entrant juste les nombres et en supprimant les vides :

Sub SupprimeLignesPaires()
Dim t!, P As Range
t = Timer
Application.ScreenUpdating = False
Set P = ActiveSheet.UsedRange
P.Columns(1).Insert xlToRight 'colonne auxiliaire
P(1, 0) = 1 'un nombre, un vide
P(1, 0).Resize(2).AutoFill P(1, 0).Resize(P.Rows.Count), xlFillValues
With P(1, 0).Resize(P.Rows.Count, P.Columns.Count + 1)
  .Sort P(1, 0) 'le tri met les vides en bas
  .Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
  .Columns(1).Delete xlToLeft 'supprime la colonne auxiliaire
End With
Application.ScreenUpdating = True
MsgBox "Durée " & Format(Timer - t, "0.00 \s")
End Sub

Nota : pour supprimer les lignes impaires remplacer xlCellTypeBlanks par xlCellTypeConstants.

A+

 

[Staple1600]

Re : VBA : Supprimer 1 ligne sur 2

Re, Bonjour leti(😉), job75 (😉)

Avec le code de job75 (celui de ce message )

.Columns(1).SpecialCells(xlCellTypeConstants, 2).Rows = Empty

C'est plus rapide ici qu'avec sa version. Et chez vous?

EDITION1: C'est la cas aussi avec ton dernier code Job75
(Plus rapide aussi ainsi ici)

.Columns(1).SpecialCells(xlCellTypeBlanks).Rows = Empty

EDITION2: Pour infos
Durée Macro Job75: 0,77 s
Durée Macro LETI: 1,97 s

 

[job75]

Re : VBA : Supprimer 1 ligne sur 2

Re,

J'ai testé la méthode par tableau de Laetitia 🙂

Sur mon fichier de 60000 lignes et une seule colonne => 0,14 seconde.

Finalement avec des tableaux c'est toujours plus rapide.

A+

 

[Staple1600]

Re : VBA : Supprimer 1 ligne sur 2

Re


Job75: tu dois avoir une machine puissante (voir tests dans mon précédents messages) 😉
J'ai testé avec ceci:
Lancer la macro testMacros (les résutats sont à voir dans VBE)
[TABLE="width: 800"]
[TR]
[TD]

Sub testMacros()
a
SupprimeLignesPairesIV
a
leti
End Sub

[/TD]
[TD]

Private Sub a()
Application.ScreenUpdating = False
Cells = Empty
[A1] = "GARDER": [A2] = "Efface"
[A1:A2].AutoFill Destination:=Range("A1:A60000"), Type:=xlFillDefault
[B1:E2] = Time
[B1:E2].AutoFill Destination:=Range("B1:E60000"), Type:=xlFillDefault
Application.ScreenUpdating = True
End Sub

[/TD]
[/TR]
[TR]
[TD]

Private Sub SupprimeLignesPairesIV()
Dim t!, P As Range
t = Timer
Application.ScreenUpdating = False
Set P = ActiveSheet.UsedRange
P.Columns(1).Insert xlToRight 'colonne auxiliaire
P(1, 0) = 1 'un nombre, un vide
P(1, 0).Resize(2).AutoFill P(1, 0).Resize(P.Rows.Count), xlFillValues
With P(1, 0).Resize(P.Rows.Count, P.Columns.Count + 1)
  .Sort P(1, 0) 'le tri met les vides en bas
  .Columns(1).SpecialCells(xlCellTypeBlanks).Rows = Empty
  .Columns(1).Delete xlToLeft 'supprime la colonne auxiliaire
End With
Application.ScreenUpdating = True
Debug.Print "Durée Macro Job75: " & Format(Timer - t, "0.00 \s")
End Sub

[/TD]
[TD]

Private Sub leti()
Dim tt!
tt = Timer
Dim t(), t1(), x&, i&, y&
Application.ScreenUpdating = False
t = Range("a1:e" & Cells(Rows.Count, 1).End(xlUp).Row)
ReDim t1(1 To UBound(t), 1 To 5)
For i = 1 To UBound(t) Step 2
x = x + 1
For y = 1 To 5
t1(x, y) = t(i, y): Next y
Next i
Cells = Empty
Range("a1").Resize(x, 5) = t1
Debug.Print "Durée Macro LETI: " & Format(Timer - tt, "0.00 \s")
End Sub

[/TD]
[/TR]
[/TABLE]

 

[Cousinhub]

Re : VBA : Supprimer 1 ligne sur 2

Bonjour tout le monde,

J'étais parti sur le même principe que Leti, mais elle a été plus prompte que moi....

Je la poste quand même (le travail est fait....)

Sub suppr_1_sur_2()
Dim Tblo, Tblo2()
Dim I As Long, DerLig As Long, J As Long
Dim K As Byte
Dim T
Application.ScreenUpdating = False
T = Timer
DerLig = Cells(Rows.Count, 1).End(xlUp).Row
ReDim Tblo2(1 To DerLig / 2, 1 To 5)
Tblo = Range("A1:E" & DerLig)
J = 1
For I = LBound(Tblo) To UBound(Tblo) Step 2
    For K = 1 To 5
        Tblo2(J, K) = Tblo(I, K)
    Next K
    J = J + 1
Next I
Cells.Clear
Range("A1").Resize(UBound(Tblo2), 5).Value = Tblo2
MsgBox Timer - T
End Sub

Et pour 60 003 lignes, j'ai un temps de 0.42 s

C'était juste pour faire avancer le schimili....

Bon Dimanche

 

[Staple1600]

Re : VBA : Supprimer 1 ligne sur 2

Re, Bonjour bhbh 😉


Ici sous PC XP et XL2K3
Durée Macro bhbh: 2,22 s

(PS: Pas mon pc habituel)

 

[LouisBlanc]

Re : VBA : Supprimer 1 ligne sur 2

Vraiment super à tous.
sur mon pc :
bhbh est à 0,26s
laetitia 90 est à 0,14s
moi, à 4,5s
Les autres je n'ai pas encore testé, mais là, y a pas photo......
Bravo à tous. Maintenant je vais intégrer ça à ma macro générale.... Ah que je suis content !!!!

J'ai un autre problème que j'avais soumis sur un autre post, et là, pas de réponse.
Vous auriez peut être des idées ?

Je réalise une autre Macro VBA..
En fin de programme, j'ouvre la boite "enregistrer sous" avec un nom proposé par défaut.
Tout fonctionne bien sauf si le nom de fichier existe déjà. Un message d'alerte apparait me demandant si je veux tout de même sauver, si je veux annuler, et je peux aussi fermer la boite avec la petite "X" en haut à droite.
Si je sauve quand même, pas de problème. Mais si j'annule ou je ferme la fenêtre, bug de la macro.
Je ne trouve pas les codes permettant de traiter les réponses à cette boite de dialogue.
A savoir que je sais éviter son affichage, mais ça ne m'intéresse pas, car cette sécurité est importante pour moi.
Auriez vous des propositions ?

Si dessous la partie de code concernée.

Merci d'avance
*************

Do
NomSauve = Application.GetSaveAsFilename(InitialFileName:=NomDeSauvegarde, FileFilter:="fichier excel, *.xls", Title:="Entrer un nom")
If NomSauve <> "Faux" Then Exit Do
Loop


'' c'est ici que s'ouvre la boite d'alerte si le nom de fichier existe déjà, et je ne sais pas gérer les réponses "non", "annuler" et "fermer"

ActiveWorkbook.SaveAs Filename:= _
NomSauve _
, FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False

************

Si vous aviez quelques pistes ???

 

[Staple1600]

Re : VBA : Supprimer 1 ligne sur 2

Re


Pour tester si un fichier existe, utilises une fonction crée pour cela

[Function FileExiste(F$) as Boolean
FileExiste = Dir(F) <> vbNullString
End Function

Voir exemple d'emploi ci-dessous
'Dans un module standard

Function FileExiste(F$) As Boolean
FileExiste = Dir(F) <> vbNullString
End Function

Sub a()
Dim p$, f$
'juste utile pour le test - A SUPPRIMER une fois le test fait
Randomize
f = Application.WorksheetFunction.Rept(Int((Rnd * 123454321) ^ 1.618), 2) & ".xls"
'/////////////////////////////////////////////////////////////
p = Split(Environ(23) & Application.PathSeparator, "=")(1)
If FileExiste(p & f) Then
Workbooks.Open (p & f)
Else
MsgBox "Le fichier " & p & f & " n'existe pas!"
End If
End Sub

 

[kjin]

Re : VBA : Supprimer 1 ligne sur 2

Bonsoir,
N'apporte rien à la discussion

Bonsoir à tous
With p.Offset(, 255) 'insére la formule en colonne IV (car test fait sur PC avec XL2033)

Ca devait aller plus vite, non ?
A+
kjin