VBA - Suppression de lignes selon 3 critères + Bonus

[Shiriu]

Bonjour à tous,

C'est mon premier message et j'espère que je serai claire.

Après de multiple essai je ne parviens pas à obtenir le résultat escompté en VBA. Je sollicite donc les barons VBA.

Problématique :

- Dans le fichier en Feuille 3 uniquement je souhaiterai supprimer les doublons à la condition que :

MacroVBA = (Si valeur = 0 en colonne P,V et X alors supprimer la ligne à partir de la ligne 9. Refaire le contrôle à partir de la ligne du dessus. Poursuivre le processus jusqu' la dernière ligne + 10 lignes).

Bonus : Souligner d'un trait épais sur la dernière ligne les colonnes de 'J à P' et 'T à V' et enfin 'X'.

Bien à vous.

Cordialement.

Shiriu

 

[Dranreb]

Re : VBA - Suppression de lignes selon 3 critères + Bonus

Bonsoir.

J'ai beau relire votrte énoncé, ça revient toujours à supprimer toutes les lignes où P, V et X sont à 0. Je ne vois pas de rapport avec des doublons !? Alors :

Sub SuppLigne()
LignesOùCondR1C1(ActiveSheet.Rows(9), "AND(RC16=0,RC22=0,RC24=0)").Delete
End Sub

Function ColLignesOùRelat(ByVal CelDéb As Range, ByVal ColQuoi, ByVal Opé As String, ByVal Valeur) As Range
Rem. ——— Cellules partant de CelDéb dans sa colonne où la colonne ColQuoi est en relation Opé avec Valeur.
Set ColLignesOùRelat = Intersect(LignesOùRelat(CelDéb, ColQuoi, Opé, Valeur), CelDéb.EntireColumn)
End Function

Function LignesOùRelat(ByVal LigneDéb As Range, ByVal ColQuoi, ByVal Opé As String, ByVal Valeur) As Range
Rem. ——— Lignes entières partant de LigneDéb où la colonne ColQuoi est en relation Opé avec une Valeur.
If Not IsNumeric(ColQuoi) Then ColQuoi = LigneDéb.Worksheet.Columns(ColQuoi).Column
If VarType(Valeur) = vbString Then Valeur = """" & Replace(Valeur, _
   """", """""") & """" Else Valeur = Trim$(Str$(Valeur))
Set LignesOùRelat = LignesOùCondR1C1(LigneDéb, CondR1C1:="RC" & ColQuoi & Opé & Valeur)
End Function

Function ColLignesOùCondR1C1(ByVal CelDéb As Range, ByVal CondR1C1 As String) As Range
Rem. ——— Cellules partant de CélDéb dans sa colonne dont les lignes vérifient une condition R1C1 CondR1C1.
Set ColLignesOùCondR1C1 = Intersect(LignesOùCondR1C1(CelDéb, CondR1C1), CelDéb.EntireColumn)
End Function

Function LignesOùCondR1C1(ByVal LigneDéb As Range, ByVal CondR1C1 As String) As Range
Rem. ——— Lignes entières partant de LigneDéb qui vérifient une condition R1C1 CondR1C1.
Dim Lignes As Range, ColTrv As Range
With LigneDéb.Worksheet.UsedRange
   Set Lignes = LigneDéb.EntireRow.Resize(.Rows.Count + .Row - LigneDéb.Row)
   Set ColTrv = Intersect(.Columns(.Columns.Count + 1), Lignes): End With
ColTrv.FormulaR1C1 = "=1/(" & CondR1C1 & ")"
On Error Resume Next
Set LignesOùCondR1C1 = ColTrv.SpecialCells(xlCellTypeFormulas, 1).EntireRow
ColTrv.Delete xlShiftToLeft
End Function

Remarque: seule la dernière Function est utilisée, mais gardez les autres dans un coin, on ne sait jamais; ça peut toujours servir.

 

[Shiriu]

Re : VBA - Suppression de lignes selon 3 critères + Bonus

Bonjour Dranreb,

Oui effectivement il ne s'agit nullement de doublon mais bien de suppression de ligne.

Je serai pris aujourd'hui et en parti demain mais je regarderai ton code demain.
Il a l'air plutôt balaise ton code. Je m'attendais a quelque chose de plus simple.

Merci de ton retour.

Je reviendrai sur le fil pour actualiser mes tests.

 

[Shiriu]

Re : VBA - Suppression de lignes selon 3 critères + Bonus

Re-Bonjour Dranreb,

Le code VBA fonctionne très bien. Sauf que je ne comprend pas l'enchainement.
Pourrais-tu m'éclairer et corriger mes argumentations ?

1 - je ne comprend pas le code ni comment il fonctionne. J'ai quelque bride d'info mais sans certitude.
2 - Le code commence par un SUB ok mais fini à la ligne suivante par un End Sub.
3 - Dans le fichier complet cette étape vas apparaitre disons à l'étape 9 sur 15. Comment j'insère le code avec le SUB et END SUB

Sub SuppLigne ok()
'
' SuppLigne Macro
'
'Sub SuppLigne()
'== Variable déclarer ?? La feuille est active a partir de la ligne 9 pour les colonnes 16,22 et 24 a supprimer.
LignesOùCondR1C1(ActiveSheet.Rows(9), "AND(RC16=0,RC22=0,RC24=0)").Delete
End Sub

'== Utilise la variable (LigneOuCond) pour ????
Function LignesOùCondR1C1(ByVal LigneDéb As Range, ByVal CondR1C1 As String) As Range
Rem. ——— Lignes entières partant de LigneDéb qui vérifient une condition R1C1 CondR1C1.

Dim Lignes As Range, ColTrv As Range
With LigneDéb.Worksheet.UsedRange
Set Lignes = LigneDéb.EntireRow.Resize(.Rows.Count + .Row - LigneDéb.Row)

'== Comment il trouve la colonne Y avec uniquement le +1 j'ai mis +3 pour test
Set ColTrv = Intersect(.Columns(.Columns.Count + 3), Lignes): End With

'== Insère dans la colonne (+3 = AA) la valeur 1 ou Erreur de condition
ColTrv.FormulaR1C1 = "=1/(" & CondR1C1 & ")"

'== Dans les erreurs supprime les lignes en erreurs jusqu' à la fin du fichier.
On Error Resume Next
Set LignesOùCondR1C1 = ColTrv.SpecialCells(xlCellTypeFormulas, 1).EntireRow
ColTrv.Delete xlShiftToLeft
End Function

'End Sub

En tous cas je trouve que c'est déjà du lourd. J'avoue que je pensais trouvé un code beaucoup plus simple.

Ci-dessous mes premier essais :

' Dim Numeroligne As Long
' Numeroligne = 9
' Do While Range("J" & Numeroligne).Value <> Empty
' If Range("P" & Numeroligne).Value = "0" And Range("V" & Numeroligne).Value = "0" Then
' Rows(Numeroligne).Select
' Selection.Delete Shift:=xlUp
' Numeroligne = Numeroligne - 1
' End If
' Numeroligne = Numeroligne + 1
' Loop

ou

' === Suppression des lignes à 0 ===
' Si colonne 'P' = 0 et colonne 'V' = 0 alors supprimer la ligne.
'Passer à la ligne suivante et renouvellé l'opération.

'Sub SupprimerB1B10()
Dim Plage As Range
Dim Cellule As Range
' Feuil13 est et doit être le nom de code de la feuille visée
' Si ce n'est pas le cas modifier en conséquence.
Set Plage = Feuil13.Range("X1:X")
For Each Cellule In Plage.Cells
If Cellule = 0 Then
Cellule.EntireRow.Delete
End If
Next
'End Sub


Dim i As Integer
With ThisWorkbook.Sheets("Feuil13") 'Précisez le nom de votre feuille
For i = .Range("X9" & .Rows.Count).End(xlUp).Row To 2 Step -1
'Je travaille sur la colonne X
'Rows.count permet de retourner le nombre de ligne de la plage range
If .Range("X" & i).Value = "0" Then
.Rows(i).Delete
End If
Next i
End With


'Sub SuppLigne()
' Sheets("feuil13").Select
Dim Cel As Range
For Each Cel In Range("X9:X" & [X65000].End(xlUp).Row)
If Range("X9" & Cel).Value = 0 Then
Cel.Rows.Delete
End If
Next Cel
End Sub

Bonne réception.

Cordialement.

Shiriu

 

[Dranreb]

Re : VBA - Suppression de lignes selon 3 critères + Bonus

Bonsoir.
Mettez la fonction LignesOùCondR1C1 dans un module à part nommé Utilit par exemple. C'est une fonction de service qui peut servir à des tas de choses. Elle isole d'un coup toutes les lignes d'une plage commençant par une ligne spécifiée qui vérifient une condition R1C1 sous forme d'un objet Range qu'elle renvoie. C'est peut être un peu compliqué mais plus rapide à exécuter que tout ce que vous pourriez faire d'autre. Pas une seule boucle n'est nécessaire: vous supprimez toutes ces lignes d'un seul coup. Ne retouchez pas cette fonction elle est écrite comme il faut. C'est une fonction de service qui ne se retouche pas. C'est comme si elle était dans une bibliohèque fournie dont vous ne pourriez pas voir le code. Il suffit seulement de comprendre ce qu'elle renvoie. Elle renvoie toutes les lignes entières partant de celle spécifiée en 1er paramètre qui vérifient une condition R1C1 spécifiée en second paramètre.
LignesOùCondR1C1(ActiveSheet.Rows(9), "AND(RC16=0,RC22=0,RC24=0)") renvoie donc toute les lignes à partir de la 9ième de la feuille active qui vérifie la condition R1C1 "AND(RC16=0,RC22=0,RC24=0)"
C'est à dire dont seraient à VRAI les cellules d'une colonne qui porterait comme FormulaR1C1 "=AND(RC16=0,RC22=0,RC24=0)", soit, pour la ligne 9, en FormulaLocal "=ET($P9=0;$V9=0;$X9=0)"
Mais au hasard de vos questions je réponds quand même à une: inutile de prendre comme colonne de travail la 3ième après la dernière de la UsedRange de la feuille contenant la ligne de départ, la 1ère suffit.

 

[Regueiro]

Re : VBA - Suppression de lignes selon 3 critères + Bonus

Bonsoir le Forum, Shiriu
Voici ton Code : A adapter pour la Suppression de la Ligne

Sub SuppLigne()
Dim Cel As Range
Dim Derlig
Dim i As Integer
Dim plage As Range
Dim tablo

With Worksheets("IBAL")
For Each Cel In .Range(.[P9], .[P65000].End(xlUp))
If Cel.Value = 0 And Cel.Offset(, 6).Value = 0 And Cel.Offset(, 8).Value = 0 Then
'COLORIE LA LIGNE
Cel.Offset(, -6).Resize(, 15).Interior.ColorIndex = 4
'MASQUE LA LIGNE
'Cel.EntireRow.Hidden = True
'EFFACE LA LIGNE*
'Cel.EntireRow.Delete
End If
Next Cel
Derlig = Range("J65000").End(xlUp).Row
MsgBox Derlig
tablo = Array(10, 11, 12, 13, 14, 15, 16, 20, 21, 22, 24)
'Set plage = Columns(tablo(0))
Set plage = Cells(Derlig, tablo(0))
MsgBox plage.Address


For i = 1 To UBound(tablo)
        'Set plage = Union(plage, Columns(tablo(i)))
        Set plage = Union(plage, Cells(Derlig, tablo(i)))
        
        
Next i
 

plage.Select

    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
         .ColorIndex = xlAutomatic
        .Weight = xlThick
    End With

End With
End Sub

 

[Shiriu]

Re : VBA - Suppression de lignes selon 3 critères + Bonus

Bonjour à tous,

Désoler de vous répondre si tardivement mais je n'avais pas eu le temps de faire d'autres tests.
C'est donc chose faite.

Dranreb : Je suis très intéressé justement par les fonctions très faible en ressource et au traitement complet en une passe.
Je reprendrai la formule pour mieux l'assimilé cette été ou j'aurai plus de temps.
J'ai juste un manque de pratique et de connaissances en VBA pour assimiler la mécanique et avoir une lecture de code plus aisé.

J'ai pour l'instant adopté la formule de 'Regueiro' que je comprends mieux. Ou du moins que je peux plus manipuler.

Regueiro : La formule fonctionne très bien et j'ai put facilement l'adapté à mon usage.
Il me manque juste une fonction dans ta formule.
Si dans le fichier j'ai une série de 10 lignes à 0, je n'arrive pas faire redémarrer le code deux lignes au dessus. Le code passe sur la ligne suivante en oubliant celle sur laquelle il était.

Ce que je ne comprends pas :
1 - Il s'agit d'une simulation de tableau ? Un petit complément d'info serait super

tablo = Array(10, 11, 12, 13, 14, 15, 16, 20, 21, 22, 24)

2 - A quoi sert le code si dessous ?

For i = 1 To UBound(tablo)
'Set plage = Union(plage, Columns(tablo(i)))
Set plage = Union(plage, Cells(Derligfob, tablo(i)))


Next i

Je remets le code entier si besoin. Si les arguments sont faux je veux bien une correction.

Sub SuppLigne()

Dim Cel As Range
Dim Derligfob
Dim i As Integer
Dim plage As Range
Dim tablo

' === Suppression des lignes à 0 ===

'===FOB - Test Ok pour suppression de ligne =====
'Sub SuppLigneREGUEIRO()

With Worksheets("IBAL")
'==Sélection de la colonne N à partir de la ligne 9 jusqu'à la fin
For Each Cel In .Range(.[N9], .[N65000].End(xlUp))
If Cel.Value = 0 And Cel.Offset(, 1).Value = 0 And Cel.Offset(, 5).Value = 0 And Cel.Offset(, 6).Value = 0 Then

'==Coloration de la ligne
Cel.Offset(, -6).Resize(, 15).Interior.ColorIndex = 4

'==Masque la ligne
'Cel.EntireRow.Hidden = True

'==Efface la ligne*
Cel.EntireRow.Delete
End If
Next Cel
Derligfob = Range("L65000").End(xlUp).Row
'MsgBox Derlig
tablo = Array(10, 11, 12, 13, 14, 15, 16, 20, 21, 22, 24)
'Set plage = Columns(tablo(0))
Set plage = Cells(Derligfob, tablo(0))
'MsgBox plage.Address
End With

For i = 1 To UBound(tablo)
'Set plage = Union(plage, Columns(tablo(i)))
Set plage = Union(plage, Cells(Derligfob, tablo(i)))


Next i


plage.Select

With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.Weight = xlThick
End With

End With

'Fin 1er Test de suppression de ligne

En tous cas un grand merci. Je m'améliore à chaque passage sur VBA.

Bien à vous.

 

[Shiriu]

Re : VBA - Suppression de lignes selon 3 critères + Bonus

Bonjour à tous,

Il me manque juste une fonction dans la formule.
Si dans le fichier j'ai une série de 10 lignes à 0, je n'arrive pas faire redémarrer le code deux lignes au dessus après supprimer une ligne. Le code passe sur la ligne suivante en oubliant celle sur laquelle il était.

Je remets le code entier si besoin. Si les arguments sont faux je veux bien une correction :
Précision le code fonctionne très bien.

Sub SuppLigne()

Dim Cel As Range
Dim Derligfob
Dim i As Integer
Dim plage As Range
Dim tablo

' === Suppression des lignes à 0 ===

'===FOB - Test Ok pour suppression de ligne =====
'Sub SuppLigneREGUEIRO()

With Worksheets("IBAL")
'==Sélection de la colonne N à partir de la ligne 9 jusqu'à la fin
For Each Cel In .Range(.[N9], .[N65000].End(xlUp))
If Cel.Value = 0 And Cel.Offset(, 1).Value = 0 And Cel.Offset(, 5).Value = 0 And Cel.Offset(, 6).Value = 0 Then

'==Coloration de la ligne
Cel.Offset(, -6).Resize(, 15).Interior.ColorIndex = 4

'==Masque la ligne
'Cel.EntireRow.Hidden = True

'==Efface la ligne*
Cel.EntireRow.Delete
End If
Next Cel
Derligfob = Range("L65000").End(xlUp).Row
'MsgBox Derlig
tablo = Array(10, 11, 12, 13, 14, 15, 16, 20, 21, 22, 24)
'Set plage = Columns(tablo(0))
Set plage = Cells(Derligfob, tablo(0))
'MsgBox plage.Address
End With

For i = 1 To UBound(tablo)
'Set plage = Union(plage, Columns(tablo(i)))
Set plage = Union(plage, Cells(Derligfob, tablo(i)))


Next i


plage.Select

With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.Weight = xlThick
End With

End With

'Fin 1er Test de suppression de ligne

Bonne journée à tous.
Shiriu.