VBA : Supprimer 1 ligne sur 2

L

LouisBlanc

XLDnaute Nouveau
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
 
Trier par date Trier par votes
job75

job75

XLDnaute Barbatruc
Re : VBA : Supprimer 1 ligne sur 2

Re,

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

Code: 
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+
 
Dernière édition:
Vote positif 0 Vote négatif
mapomme

mapomme

XLDnaute Barbatruc
Supporter XLD
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é) :mad:
Voici la correction.
 

Pièces jointes

  • Suppr ligne IMpaire v3.xls
    46 KB · Affichages: 78
  • Suppr ligne paire v3.xls
    48 KB · Affichages: 78
Vote positif 0 Vote négatif
L

LouisBlanc

XLDnaute Nouveau
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
 
Vote positif 0 Vote négatif
L

laetitia90

XLDnaute Barbatruc
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

Code: 
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
 
Vote positif 0 Vote négatif
L

LouisBlanc

XLDnaute Nouveau
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
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : VBA : Supprimer 1 ligne sur 2

Re,

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

Code: 
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+
 
Vote positif 0 Vote négatif
Staple1600

Staple1600

XLDnaute Barbatruc
Re : VBA : Supprimer 1 ligne sur 2

Re, Bonjour leti(;)), job75 (;))

Avec le code de job75 (celui de ce message )
Code: 
.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)
Code: 
.Columns(1).SpecialCells(xlCellTypeBlanks).Rows = Empty

EDITION2: Pour infos
Durée Macro Job75: 0,77 s
Durée Macro LETI: 1,97 s
 
Dernière édition:
Vote positif 0 Vote négatif
Staple1600

Staple1600

XLDnaute Barbatruc
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)
Code: 
Sub testMacros()
a
SupprimeLignesPairesIV
a
leti
End Sub
Code: 
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
Code: 
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
Code: 
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
 
Dernière édition:
Vote positif 0 Vote négatif
Cousinhub

Cousinhub

XLDnaute Barbatruc
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....)

Code: 
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
 
Vote positif 0 Vote négatif
L

LouisBlanc

XLDnaute Nouveau
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 ???
 
Vote positif 0 Vote négatif
Staple1600

Staple1600

XLDnaute Barbatruc
Re : VBA : Supprimer 1 ligne sur 2

Re


Pour tester si un fichier existe, utilises une fonction crée pour cela
Code: 
[Function FileExiste(F$) as Boolean
FileExiste = Dir(F) <> vbNullString
End Function

Voir exemple d'emploi ci-dessous
'Dans un module standard
Code: 
Function FileExiste(F$) As Boolean
FileExiste = Dir(F) <> vbNullString
End Function
VB: 
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
 
Vote positif 0 Vote négatif

Discussions similaires

B
  • Question
XL 2013 Comment trier les nom des feuilles et fusionner leur tableaux dans une une autre feuille ?
Réponses
10
Affichages
213
Compte Supprimé 979
C
B
  • Question
Microsoft 365 [RESOLU] Supprimer Ligne rapidement et avec plusieurs conditions
Réponses
5
Affichages
118
BENAM69
B
PORCHER
  • Question
Microsoft 365 L'indice n'appartient pas à la sélection
Réponses
8
Affichages
316
TooFatBoy
TooFatBoy
L
  • Résolu(e)
Microsoft 365 Suppression de cellules vide
Réponses
3
Affichages
184
Le Rouky
L
S
  • Question
Microsoft 365 VBA pour copier une une des données d'une ligne à une autre
Réponses
2
Affichages
148
crocrocro
C
G
  • Question
Microsoft 365 Saut de ligne dans une cellule
Réponses
3
Affichages
145
GClaire
G
M
  • Question
Microsoft 365 Macro VBA supprimer une colonne
Réponses
5
Affichages
109
marie3107
M
S
  • Résolu(e)
XL 2016 problème de filtre dans listbox
2 3 4
Réponses
51
Affichages
1 K
saidoush
S
C
  • Résolu(e)
XL 2021 Alimenter Listbox si colonne 3 contient un mot précis
Réponses
5
Affichages
243
Claudinedu13
C
Sergent_Lipton
  • Résolu(e)
Microsoft 365 [VBA] Barre de recherche dynamique - objectif : cacher les lignes hors résultat
Réponses
3
Affichages
198
Sergent_Lipton
Sergent_Lipton

Membres actuellement en ligne

4 membres et 51 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 229
Messages
2 086 423
Membres
103 206
dernier inscrit
diambote