Microsoft 365 Effacer le contenu si cellule suivante identique

[Faroyo]

Bonjour,

Je suis à la recherche d'un code VBA permettant d'effacer le contenu de la cellule suivante si celle-ci est identique. J'ai fait plusieurs tentatives mais sans succès. C'est pourquoi, je fais appel à votre savoir et votre gentillesse pour m'aider à la résolution de mon pb.

La valeur à comparer se trouve en colonne "B"

Si B3 = B2, B3 = "" et ainsi de suite.

Bien cordialement,

Faroyo

 

[Phil69970]

Bonjour @Faroyo

Je te propose ce fichier

Merci de ton retour

 

[fanch55]

Salut,
A mettre dans le code de sheet1 :

Sub SupDessous() ' pour traiter toute la colonne,
Dim Lr As Range, I As Long
    Set Lr = Columns("B").Find("", , , , xlPrevious)
    If Not Lr Is Nothing Then
        For I = Lr.Row To 2 Step -1
            Compress_Column Cells(I, "B")
        Next
    End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Column = Columns("B").Column Then
        Compress_Column Target(1)
    End If
End Sub

Sub Compress_Column(Cell As Range)
Application.EnableEvents = False
    Select Case Cell
        Case Is = ""
        Case Is <> Cell.Offset(-1)
        Case Else: Cell.ClearContents
    End Select
Application.EnableEvents = True
End Sub

 

[Faroyo]

Merci pour ce retour rapide et parfaitement fonctionnel.
J'aimerai savoir s'il était possible d'effacer en meme temps le contenu des colonnes A, C et D

Merci

 

[Phil69970]

Re
Bonjour François

@Faroyo

J'aimerai savoir s'il était possible d'effacer en meme temps le contenu des colonnes A, C et D

Comme ceci ?

 

[Faroyo]

Salut,
A mettre dans le code de sheet1 :

Sub SupDessous() ' pour traiter toute la colonne,
Dim Lr As Range, I As Long
    Set Lr = Columns("B").Find("", , , , xlPrevious)
    If Not Lr Is Nothing Then
        For I = Lr.Row To 2 Step -1
            Compress_Column Cells(I, "B")
        Next
    End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Column = Columns("B").Column Then
        Compress_Column Target(1)
    End If
End Sub

Sub Compress_Column(Cell As Range)
Application.EnableEvents = False
    Select Case Cell
        Case Is = ""
        Case Is <> Cell.Offset(-1)
        Case Else: Cell.ClearContents
    End Select
Application.EnableEvents = True
End Sub

Merci pour votre réponse, comme pour Phil69970 rien à dire. Le code fonctionne parfaitement et meme question pour vous, serait-il possible d’étendre l'effacement des cellules aux colonnes A , C et D.

Merci

​

Re
Bonjour François

@Faroyo


Comme ceci ?

C'est top.
C'est juste parfait. Un très grand merci à vous pour votre temps et votre partage connaissances.

Une tres bonne journée

Cordialement,
Faroyo

 

[Phil69970]

@Faroyo

Et si tu veux regrouper les lignes pour ne plus avoir des lignes vides.....

 

[Faroyo]

@Faroyo

Et si tu veux regrouper les lignes pour ne plus avoir des lignes vides.....

Merci Phil69970, c'est au delà de mes espérances.
Je te remercie encore pour ta disponibilité.

Tres bonne continuation.

Faroyo

 

[fanch55]

Le code fonctionne parfaitement et meme question pour vous, serait-il possible d’étendre l'effacement des cellules aux colonnes A , C et D.

Finalement, c'est la ligne entière que vous désirez supprimer,
pour le fun :

Sub SupDessous()
Dim Lr As Range, I As Long
Application.EnableEvents = False
    Set Lr = Columns("B").Find("", , , , xlPrevious)
    If Not Lr Is Nothing Then
        For I = Lr.Row To 2 Step -1
            Select Case Cells(I, "B")
                Case Is = ""
                Case Is <> Cells(I, "B").Offset(-1)
                Case Else: Rows(I).Delete
            End Select
        Next
    End If
Application.EnableEvents = True
End Sub