Microsoft 365 Effacer le contenu si cellule suivante identique

Faroyo

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

Pièces jointes

  • valeur suivante.xlsx
    14.2 KB · Affichages: 6

fanch55

XLDnaute Barbatruc
Salut,
A mettre dans le code de sheet1 :
VB:
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

XLDnaute Junior
Salut,
A mettre dans le code de sheet1 :
VB:
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
 

fanch55

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

Discussions similaires

Réponses
7
Affichages
407

Statistiques des forums

Discussions
313 195
Messages
2 096 101
Membres
106 495
dernier inscrit
dylan.44