Macro pour supprimer les cellules doublons+la cellule original

Bonjour à tous,

j ai un problème avec un ficihier et je voulais créer un boutton pour supprimer les doublons plus la cellule originelle exemple si dans la colonne

1111

2222

3333

1111

1111

Je voudrais après clique sur boutton lié avec code macro me reste

2222

3333

le boutton dans la feuil 1 et la liste dans la feuil 2.

merci d'avance

Bonjour,

Voici un essai où il faudra adapter avec vos références :

sub suppmulti()
with activesheet '<<< adapter
    with .range("A1:A100") '<<< adapter
        t = .value2
        for i = 1 to ubound(t)
            if application.countif(.cells, t(i, 1)) = 1 then
                n = n + 1
                t(n, 1) = t(i, 1)
            end if
        next i
        .clearcontents
        if n > 0 then .resize(n).value2 = t
    end with
end with
end sub

Cdlt,

Merci 3GB,

Merci pour la réponse

j ai essayé de mettre le code que tu m a proposé mais il y a une erreur 424 objet requis

Sub Entreee()
With Sheets("Data").Activate ' la feuille 1 où le boutton macro
With .Range("F2:F40") 'la feuille 2 où l'action se passe
t = .Value2
For i = 1 To UBound(t)
If Application.CountIf(.Cells, t(i, 1)) = 1 Then
n = n + 1
t(n, 1) = t(i, 1)
End If
Next i
.ClearContents
If n > 0 Then .Resize(n).Value2 = t
End With
End With
End Sub

Cdt,

Bonjour tout le monde,
Une proposition avec ordre alphabétique :

Sub deDoublon()
    Dim tablo() As String
    Dim i As Integer, j As Integer, doublon As Boolean
    Dim compt As Integer, index As Integer
    Dim nl As Integer, exclus As String, min As String

    nl = Sheets("Feuil1").Cells(Columns.Count, 1).End(xlUp).Row

    ReDim tablo(0)
    tablo(0) = Cells(2, 1)
    compt = 0
    If ActiveCell.Value = "" Then
        MsgBox "Vous devez sélectionner une cellule de la colonne à traiter.", vbCritical + vbOKOnly, "Erreur"
        Exit Sub
    End If

    Cells(1, 2) = "Valeurs uniques"    
    For i = 3 To nl
        doublon = False
        For j = 0 To UBound(tablo)
            If tablo(j) = Cells(i, 1) Then
                doublon = True
                Exit For
            End If
        Next j
        If doublon = False And Cells(i, 1) <> ActiveCell.Value Then
            compt = compt + 1
            ReDim Preserve tablo(compt)
            tablo(compt) = Cells(i, 1)
        End If
    Next i

    ' Tri dans l'ordre alphabétique
    For i = 0 To UBound(tablo)
        min = "zzzz"
        For j = 0 To UBound(tablo)
            If min > tablo(j) Then
                min = tablo(j)
                index = j
            End If
        Next j
        tablo(index) = "zzzz"
        Cells(i + 2, 2) = min
    Next i
End Sub

Bonjour,

A Kamalo, le code de 3GB (salut) est correct, dans votre modif, il est inutile de préciser la feuille où se trouve le bouton, par contre il faut préciser celui de la feuille 2

votre code, remplacez "Votre feuille2" par le nom réel de votre feuille 2

Sub Entreee()
With Sheets("Votre feuille2").Range("F2:F40") 'la feuille 2 où l'action se passe
t = .Value2
For i = 1 To UBound(t)
If Application.CountIf(.Cells, t(i, 1)) = 1 Then
n = n + 1
t(n, 1) = t(i, 1)
End If
Next i
.ClearContents
If n > 0 Then .Resize(n).Value2 = t
End With
End Sub

Cdlt

Bonjour à tous,

Avec l'instruction with, on met un objet (une feuille par exemple ou une plage), ça permet de le "cibler". Dans le cas des feuilles, c'est un moyen d'appliquer des méthodes dessus sans les activer. .Activate est une méthode (une action sur la feuille). Lorsqu'on met .Sheets("??").activate sous l'instruction with, VBA interprète autre chose qu'un objet, d'où le blocage.

Voici un nouvel essai (quasiment identique à celui celui d'Arturo ) avec activation de la feuille 2 suite à la suppression des doublons :

Sub Entreee()
With Sheets(2) '<<< A ADAPTER
    With .Range("F2:F40") 'la feuille 2 où l'action se passe
        t = .Value2
        For i = 1 To UBound(t)
            If Application.CountIf(.Cells, t(i, 1)) = 1 Then
                n = n + 1
                t(n, 1) = t(i, 1)
            End If
        Next i
        .ClearContents
        If n > 0 Then .Resize(n).Value2 = t
    End With
    .activate
End With
End Sub

Cdlt,

Bonjour à tous,

Merci pour vos réponse,

malheureusement j ai pas réussi vu que j'ai un autre macro dans le boutton, veuillez trouver mon fichier en pièce jointe et j'aimerais bien de me corriger les erreurs SVP.

Merci encore une fois!

Bonjour Kamalo,

Est-ce que tu peux poster le code ?

La macro ne nécessite pas de bouton, elle peut être exécutée depuis l'éditeur ou par un autre moyen. Mais le plus simple serait de créer un nouveau bouton (onglet développeur/Insérer/clic sur le premier logo des controles de formulaire/clic sur la feuille) et de lui affecter cette nouvelle macro (clic droit sur le bouton/affecter une macro).

Cdlt,

Merci beaucoup 3GB,

sauf maintenant j ai un problème que le bouton prend quelques second(10 s à peu près) pour exécuter la macro!

Avez vous une solution SVP?

10 secondes pour 40 lignes ?

Et avec ce code :

Sub Entreee()
application.calculation = xlcalculationmanual
With Sheets(2) '<<< A ADAPTER
    With .Range("F2:F40") 'la feuille 2 où l'action se passe
        t = .Value2
        For i = 1 To UBound(t)
            If Application.CountIf(.Cells, t(i, 1)) = 1 Then
                n = n + 1
                t(n, 1) = t(i, 1)
            End If
        Next i
        .ClearContents
        If n > 0 Then .Resize(n).Value2 = t
    End With
    .activate
End With
application.calculation = xlcalculationautomatic
End Sub

Cdlt,

ça fonction bien merci beaucoup 3GB!

Bonjour 3GB,

Pouvez vous m'aider dans le problème suivant:

Quand je saisis une valeur par manuellement dans une colonne dans le but d'avoir une saisie automatique de date dans la colonne à coté ça marche très bien mais quand je saisis par un bouton macro ça donne comme date automatique 00/01/1900. Avez vous une solution SVP?

Veuillez trouver le fichier en pièce jointe.

Merci d'avance!

Bonjour Kamalo,

La date 00/01/1900 correspond à la valeur 0. Il est possible d'appliquer le format personnalisé suivant :

JJ/MM/AAAA;;

pour renvoyer vide dans ce cas.

A appliquer à toute la plage concernée...

Cdlt,

Bonjour 3GB,

j'ai fait la personalisation format jj/mm/aaaa;; mais ça focntionne pas!

Avez vous d'autres solution SVP?

Merci

Bonjour 3GB,

Je voulais juste préciser que quand je fais ça manuellement ça marche bien mais quand je saisis à l'aide de bouton Macro ça marche pas!!

Merci!

Il n'y a pas de raison que ça ne marche pas avec la macro ci-dessus, surtout avec la propriété .value2 et si tu as défini un format personnalisé sur la plage de destination. En revanche, si tu utilises une autre macro, c'est possible...

Cdlt,

Je vous envoie le fichier en piece jointe et merci de me courriger l erreur.

Merci d avance!