VBA : Sup ligne avec condition

[titine06]

Bonjour le forum !!

J'aimerai à l'aide de VBA supprimer des lignes en fonction d'une de leur cellule:

Ca veut strictement rien dire mais en formule ca donnerai quelque chose comme ca:

pour chaque ligne d'une feuille : Si(et(E<>"Bleu";E<>"Vert");Supprimer la ligne;"")


En gros, pour chaque ligne, si la cellule E est différente de plusieurs valeurs (dans cette exemple: "Bleu" ou "Vert") alors j'aimerai que la ligne disparaisse.

Mon niveau VBA étant inexistant, je n'ai pas la moindre idée de comment faire cela...

Voici un fichier excel si ca peut aider

Si vous avez des pistes je suis preneur !

merci d'avance et bonne journée !

Titine

 

[jp14]

Re : VBA : Sup ligne avec condition

Bonjour

Ci dessous une macro.
Quand on supprime on doit toujours partir de la dernière ligne.

Option Explicit
Sub suppress()
Dim i As Long
Dim Nomfeuille1 As String
' pour boucler sur la colonne 1

Nomfeuille1 = "Feuil1"

With Sheets(ActiveSheet.Name)

For i = .Cells(Columns(5).Cells.Count, 5).End(xlUp).Row To 1 Step -1
    
    Select Case .Range("E" & i)
        Case "Vert", "Bleu"

        Case Else
            .Rows(i).Delete Shift:=xlUp
    End Select
    
Next i
End With
End Sub

a tester

JP

 

[titine06]

Re : VBA : Sup ligne avec condition

Bonjour JP,

Le code marche à merveille !!

Merci beaucoup !!

Titine

 

[titine06]

Re : VBA : Sup ligne avec condition

Re,

Juste une ptite question,
quand je lance le code, ca prend quand meme pas mal de temps, y aurait il moyen de racourcir ce délai?

Par exemple au lieu de vérifier si une valeur est "Bleu" ou "Verte" pour ne pas la supprimer, peut être que ce serait plus rapide de rechercher ce qui est "Rouge" ou "vide(pas de valeur" pour le supprimer?

merci d'avance

titine

 

[Pierrot93]

Re : VBA : Sup ligne avec condition

Re titine, bonjour jp

en l'absence de jp, essaye peut être ainsi :

Option Explicit
Sub suppress()
Dim i As Long
Dim Nomfeuille1 As String
Nomfeuille1 = "Feuil1"
With Sheets(ActiveSheet.Name)
    For i = .Cells(Columns(5).Cells.Count, 5).End(xlUp).Row To 1 Step -1
        If IsEmpty(.Range("E" & i)) Or LCase(.Range("E" & i)) = "rouge" Then .Rows(i).Delete Shift:=xlUp
    Next i
End With
End Sub

bon après midi
@+

 

[titine06]

Re : VBA : Sup ligne avec condition

Re Pierrot !

Encore une fois merci !!
Le code marche très bien dans ce sens.. Mais j'avais tord, meme dans ce sens ca prend beaucoup de temps.. Tempis pour moi !
Ca prendra du temps et puis c'est tout !

merci à vous !!

Titine

 

[titine06]

Re : VBA : Sup ligne avec condition

Re !

Désolés si je flood un peu, c'est pas le but, je fais beaucoup de test en meme temps....
Si j'ai bien compris, la macro pour chaque valeur correspondante à la condition supprime. Donc elle supprime une ligne par une ligne?
Si oui, ne serait il pas plus rapide qu'elle selectionne dans un premier temps les valeurs correspondantes aux conditions:
If IsEmpty(.Range("E" & i)) Or LCase(.Range("E" & i)) = "rouge" Then .Rows(i).Delete
pour ensuite les supprimer toute d'un seul coup?

merci =)

titine

 

[Pierrot93]

Re : VBA : Sup ligne avec condition

Re,

peut être supprimer les lignes dont la cellule est vide en premier...

Sub suppress()
Dim i As Long
Dim Nomfeuille1 As String
Nomfeuille1 = "Feuil1"
With Sheets(ActiveSheet.Name)
    .Range("E1", .Range("E65536").End(xlUp)).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    For i = .Cells(Columns(5).Cells.Count, 5).End(xlUp).Row To 1 Step -1
        If LCase(.Range("E" & i)) = "rouge" Then .Rows(i).Delete Shift:=xlUp
    Next i
End With
End Sub

A tester...

 

[jp14]

Re : VBA : Sup ligne avec condition

Bonjour titine06
Salut Pierrot93

Pour accélérer le code il faudrait écrire

Dim AncienmodeCalcul As Variant  
    
'en cas d'erreur on reprend la main
On Error GoTo FinProcedure
'------------------------------------------------------------
'   Au début de la macro
'------------------------------------------------------------
    AncienmodeCalcul = Application.Calculation

    With Application

    .ScreenUpdating = False 'Cette propriété a la valeur True si la mise à jour de l'écran est activée
    .EnableEvents = False
    .Calculation = xlManual
    .DisplayAlerts = False 'interdit les messages d'avertissements
    End With

.................................

'            Rétablir les paramètres
    With Application 
    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayAlerts = True
    .Calculation = AncienmodeCalcul
End With

FinProcedure:

JP

 

[titine06]

Re : VBA : Sup ligne avec condition

Bonsoir Pierrot, Jp,

Merci à vous pour vos codes !

J'ai donc d'abord utilisé le nouveau code de Pierrot qui à l'air plus rapide que j'ai adapté avec celui de JP, ce qui a apporté un net augmentation de la vitesse de traitement !
merci à vous !

Cependant, je n'ai pas pu intégrer cette partie de ton code JP:

'en cas d'erreur on reprend la main
On Error GoTo FinProcedure

Comme si ce n'était pas à la bonne place ou qu'il manquait un bout de code à mettre avec. Aurais-tu une idée?
merci d'avance


Titine

 

[ROGER2327]

Re : VBA : Sup ligne avec condition

Bonsoir à tous

Dans un autre genre, un code qui me semble assez rapide :

Sub toto()
Dim i&, j&, l&, c&, tmp, oDat(), oPlg
  With [A1]
    Set oPlg = Range(.Cells, .SpecialCells(xlLastCell))
    c = oPlg.Columns.Count
    For i = 1 To oPlg.Rows.Count
      tmp = UCase(oPlg.Cells(i, 5).Value)
      If tmp = "BLEU" Or tmp = "VERT" Then
        l = l + 1
        ReDim Preserve oDat(1 To c, 1 To l)
        For j = 1 To c
          oDat(j, l) = .Cells(i, j)
        Next j
      End If
    Next i
    oPlg.ClearContents
    .Resize(l, c).Value = WorksheetFunction.Transpose(oDat)
  End With
End Sub

​

ROGER2327
#4857

Vendredi 13 Décervelage 138 (Saint Guillotin, médecin, SQ)
21 Nivôse An CCXIX
2011-W02-1T22:49:20Z

 

[James007]

Re : VBA : Sup ligne avec condition

Bonjour Titine06 et Salut amical à tout le fil,

Dans la mesure où l'objectif principal est la vitesse d'éxécution, il semble bien que, pour supprimer des lignes sous condition, la méthode Autofilter surpasse toutes les autres ...

Sub Supprimer()
With ActiveSheet
    .AutoFilterMode = False
    With Range("e1", Range("e" & Rows.Count).End(xlUp))
          .AutoFilter 1, Criteria1:="="
          On Error Resume Next
          .Offset(1).SpecialCells(12).EntireRow.Delete
    End With
    .AutoFilterMode = False
End With
End Sub

A +

 

[jp14]

Re : VBA : Sup ligne avec condition

Bonjour a tous

A vérifier

On Error GoTo FinProcedure ' en cas d'erreur aller à l'étiquette 

.................................

FinProcedure:' les deux points indique que cette ligne est une étiquette
.....................
On Error GoTo 0 ' pour rétablir la gestion d'erreur

Il ne faut pas oublier le point de destination pour "Goto"
JP

 

[Pierrot93]

Re : VBA : Sup ligne avec condition

Bonjour à tous

petite reflexion au passe, perso aurais remis les paramètres en l'état avant la fin de procédure..

FinProcedure:
On Error GoTo 0
With Application 
    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayAlerts = True
    .Calculation = AncienmodeCalcul
End With
End Sub

bon après midi
@+

 

[jp14]

Re : VBA : Sup ligne avec condition

Bonjour le fil (re)

Ci dessous une macro avec un tableau.
Il faut que la colonne E de la dernière ligne soit remplie.
J'ai rajouté un timer pour mesurer le temps d'éxécution.

'Option Explicit
Option Base 0
Sub suppress()
Dim i As Long

Dim Nomfeuille1 As String
' pour boucler sur la colonne 1
Dim AncienmodeCalcul As Variant
Dim Tablo As Variant
Dim debut As Single
Nomfeuille1 = "Feuil1"

With Sheets(ActiveSheet.Name)
Call MsgBox("Nombre de lignes : " & .Cells(Columns(5).Cells.Count, 5).End(xlUp).Row _
            & vbCrLf & "" _
            , vbInformation, Application.Name)
End With
'en cas d'erreur on reprend la main
On Error GoTo FinProcedure
'------------------------------------------------------------
'   Au début de la macro
'------------------------------------------------------------
    AncienmodeCalcul = Application.Calculation

With Application

    .ScreenUpdating = False 'Cette propriété a la valeur True si la mise à jour de l'écran est activée
    .EnableEvents = False
    .Calculation = xlManual
    .DisplayAlerts = False 'interdit les messages d'avertissements
End With
Nomfeuille1 = "Feuil1"
debut = Timer
With Sheets(ActiveSheet.Name)
Tablo = Range("E1:E" & .Cells(Columns(5).Cells.Count, 5).End(xlUp).Row).Value
For i = UBound(Tablo, 1) To LBound(Tablo, 1) Step -1
    Select Case Tablo(i, 1)
        Case "Vert", "Bleu"

        Case Else
            .Rows(i).Delete Shift:=xlUp
    End Select
    
    
Next i
End With
'            Rétablir les paramètres

FinProcedure:
With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayAlerts = True
    .Calculation = AncienmodeCalcul
End With
On Error GoTo 0

Call MsgBox("Durée du cycle  " _
            & vbCrLf & "durée : " & (Timer - debut) & " secondes" _
            & vbCrLf & "" _
            , vbInformation, Application.Name)

End Sub

A tester

JP