Remplacer par un blanc des doublons qui se suivent dans une colonne

Bonjour,

J'ai déjà une fonction qui supprime une ligne entière d'un tableau si les données de chaque cellule sont des doublons qui se suivent mais je n'arrive pas à l'adapter pour faire la même chose sur uniquement une seule colonne vu mon niveau merdique en vba, mais heureusement c'est la dernière étape de mon projet final, voici le code :

Sub doublons()

Dim i As Integer

i = 1
Do While Cells(i, "B") <> ""
If Cells(i, "B") & Cells(i, "C") & Cells(i, "D") & Cells(i, "E") & Cells(i, "F") _
= Cells(i + 1, "B") & Cells(i + 1, "C") & Cells(i + 1, "D") & Cells(i + 1, "E") & Cells(i + 1, "F") Then
Rows(i).EntireRow.Delete
i = i - 1
Else
i = i + 1
End If
Loop
End Sub

J'ai mis le fichier en annexe, avec le tableau de départ, et à droite ce que je voudrais à l'arrivée, juste effacer les doublons qui se suivent de la colonne " registre " pour n'en garder qu'un seul à chaque fois.

Merci d'avance pour votre analyse,

Bonsoir,

Ceci est fait pour vous !
Steelson

L'avantage c'est qu'il n'y a pas de suppression de donnée, du coup les tris et les filtres fonctionnent encore, enfin je pense, il faut voir avec le contributeur Steelson.

@ bientôt

LouReeD

Bonjour,

Merci pour votre réponse, mais il me faudrait une fonction en vba car je lance plusieurs fonctions en un seul raccourci clavier, et l'action voulue est la dernière étape des manipulations du tableau justement

Bonjour,

En me basant sur votre code, j'ai apporté les modifications suivantes :

Sub doublons()

Dim i%, k%
Dim Bool as Boolean

i = 1
While Cells(i, 2) <> ""

    for k = 2 to 6 'pour colonnes 2 à 6
        If Cells(i, j).value = Cells(i + 1, k).value Then 'si cellule i = cellule i+1
            Bool = 1 'Valeur booléenne à 1
        Else: 
            Bool = 0 'sinon, à 0 et sortie de for
            Exit For
        end if
    next k

    If Bool = 1 Then    
        Rows(i+1).EntireRow.Delete 'si à l'issue de la boucle sur les 6 colonnes, Bool = 1 alors suppression de la ligne du dessus
        i = i - 1 'décrémentation pour revenir à l'incrémentation de fin de while
    end if

Bool = 0 'réinitialisation Bool
i = i + 1 'incrémentation pour tester ligne suivante
Wend

End Sub

En espérant qu'il corresponde à votre attente...

Edit: j'ai modifié une ligne car je n'avais pas gérer l'éventualité d'une succession de doublons.

Cordialement,

Bonjour,

Une autre proposition VBA.

A Tester !...

Cdlt.

Public Sub DeleteDuplicates()
Dim lastRow As Long, i As Long, tbl, arr()
    With ActiveSheet
        lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        tbl = .Cells(2, 1).Resize(lastRow - 1)
        ReDim arr(1 To UBound(tbl))
        arr(1) = tbl(1, 1)
        For i = 2 To UBound(tbl)
            If tbl(i - 1, 1) = tbl(i, 1) Then arr(i) = vbNullString Else arr(i) = tbl(i, 1)
        Next i
        .Cells(2, 1).Resize(UBound(tbl)).Value = Application.Transpose(arr)
    End With
End Sub

Ca fonctionne, merci à tout le monde !