Supprimer les lignes lorsqu'une condition est appliquée à une colonne.

[josanche]

Bonjour,

Je voudrais savoir si il y a un macro pour m'aider à supprimer les lignes de mon fichier excel pour lorsque bill position prend la valeur anti-gun ou no position afin de garder uniquement les lignes dont la colonne bill position prend la valeur Pro-gun ?

Passez un bon week-end pascal😀
Voici le lien du fichier et allez dans la feuille dummies
http://db.tt/OMDThIn2
Cordialement

 

[Robert]

Re : Supprimer les lignes lorsqu'une condition est appliquée à une colonne.

Bonjour Josanche, bonjour le forum,

Haaa Josanche quel dilemme ! Moi qui suis résolument anti-gun j'ai longuement hésité à te proposer la macro ci-dessous. Mais bon j'espère que ça va pas servier à en vendre plus...
le code :

Sub Macro1()
Dim dl As Integer
Dim i As Integer

With Sheets("Dummies")
    dl = .Cells(Application.Rows.Count, 1).End(xlUp).Row
    For i = dl To 4 Step -1
        If .Cells(i, 4).Value <> "Pro-gun" Then .Rows(i).Delete
    Next i
End With
End Sub

 

[mapomme]

Re : Supprimer les lignes lorsqu'une condition est appliquée à une colonne.

Bonsoir josanche,

Une piste avec une macro dans le module de la feuille "Dummies". Pour le fichier exemple, des colonnes ont été supprimées (pour le joindre sur le site) mais la macro prend bien en compte toutes les colonnes du fichier initial.

Sub Garder_Pro_gun()

Dim U, i, LigneMax, T1 As Double, xRg As Range

    Sheets("Dummies").Activate
    Application.ScreenUpdating = False
    T1 = Timer
    
    LigneMax = Cells(Rows.Count, "a").End(xlUp).Row
    If LigneMax < 4 Then Exit Sub
    Columns("A").Insert Shift:=xlToRight
    
    U = Range(Cells(4, "e"), Cells(LigneMax, "e")).Value
    For i = LBound(U, 1) To UBound(U, 1)
        If U(i, 1) <> "Pro-gun" Then U(i, 1) = "" Else U(i, 1) = i
    Next i
    
    Range(Cells(4, "a"), Cells(LigneMax, "a")).Value = U
    Range(Cells(4, "a"), Cells(LigneMax, "ct")).Sort key1:=Columns("a"), Header:=xlNo
    Set xRg = Range(Cells(4, "a"), Cells(LigneMax, "a"))
    Set xRg = xRg.Find(what:="", after:=xRg(1, 1), searchdirection:=xlNext)
    If Not xRg Is Nothing Then Range(xRg, Cells(LigneMax, "a")).EntireRow.Delete
    
    Columns("a").Delete
    Application.ScreenUpdating = True
End Sub

Edit: Bonjour laetitia90 & Robert 🙂

 

[laetitia90]

Re : Supprimer les lignes lorsqu'une condition est appliquée à une colonne.

bonjour josanche ,Robert🙂🙂
peut être passer par un "tablo" plus rapide

Sub es()
 Dim t(), t1(), x As Long, i As Long, y As Long
 t = Range("a4:co" & Cells(Rows.Count, 1).End(xlUp).Row)
 ReDim t1(1 To UBound(t), 1 To 93)
 For i = 1 To UBound(t)
 If t(i, 4) = "Pro-gun" Then
 x = x + 1
 For y = 1 To 93: t1(x, y) = t(i, y): Next y
 End If
 Next i
 Range("a4:co" & Cells.Find("*", , , , , xlPrevious).Row).Clear
 [A4].Resize(x, 93) = t1
 Erase t, t1
End Sub

eventuellement boucler sur les colonnes aprés pour remettre les couleurs

bonjour mapomme pas rafraichi🙂

 

[jp14]

Re : Supprimer les lignes lorsqu'une condition est appliquée à une colonne.

Bonsoir
Bonsoir laetitia90, Robert , mapomme

Ci dessous une macro
première partie : suppression des valeurs dans la colonne D en utilisant un tableau ce qui permet de diminuer le temps d’exécution
Les données sont ensuite triées puis suppression des lignes.

Option Explicit
Sub supprimer()
Dim Cellule1 As Range, Plg1 As Range
Dim Nomfeuille1 As String, Col1 As String
Dim MonTab As Variant, Compt1 As Long
Dim Isu As Long, PremLigne As Long, Dl1 As Long, Dl2 As Long
Dim AncienmodeCalcul As Variant
Nomfeuille1 = "Dummies"
Col1 = "D"
PremLigne = 2 ' première ligne
'code
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

With Sheets("Dummies")
Set Plg1 = .Range(Col1 & "4:" & Col1 & .Range(Col1 & .Rows.Count).End(xlUp).Row)
MonTab = Plg1.Value
For Compt1 = LBound(MonTab, 1) To UBound(MonTab, 1)
    If MonTab(Compt1, 1) <> "Pro-gun" Then MonTab(Compt1, 1) = ""
Next Compt1
Plg1.Value = MonTab
.Cells.Sort Key1:=.Range("D2"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal

Dl1 = .Rows.Count
Dl2 = .Range("a" & Dl1).End(xlUp).Row
Dl1 = .Range(Col1 & Dl1).End(xlUp).Row+1
        .Rows(Dl1 & ":" & Dl2).Delete
End With

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

A tester

JP