VBA effacer automatiquement un doublon

**cocomathis** · 17/05/2016, 10h27

Bonjour,

Malgré toutes mes recherches, je ne trouve pas de réponse à mon souci que voici:

j'ai 120 lignes dans la colonne A. Dans cette même colonne, je vais rentrer au fur et à mesure de la journée, des chiffres variant de 1 à 8. j'aimerais effacer la valeur identique quand je la rentre dans une nouvelle celllule.... Exemple:

- Au départ, je rentre de 1 à 8 dans A1 à A8. Plus tard, je veux rentrer un nouveau chiffre (ex:2) dans A9 et un autre dans A10 etc... et qu'à chaque fois, l'ancienne valeur identique s'efface. Si je rentre 2 dans A9, 2 qui était précédemment dans A2 disparait.

Je suppose que cette macro est classique, mais malgré toutes mes recherches, je suis dans l'impasse...

Merci d'avance à tous ceux qui se pencheront sur mon problème

**Nodens_swiss** · 17/05/2016, 10h40

Le plus simple est de faire une boucle comme suite :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
 
Public Sub test()
Dim i As Integer
Dim DernierSaisie As Integer
    DernierSaisie = 0
    For i = 119 To 0 Step -1
        If ActiveSheet.Range("A1").Offset(i, 0).Value = DernierSaisie Then
            ActiveSheet.Range("A1").Offset(i, 0).Value = ""
            Exit For
        End If
        If DernierSaisie = 0 And IsNull(ActiveSheet.Range("A1").Offset(i, 0).Value) = False Then
            DernierSaisie = ActiveSheet.Range("A1").Offset(i, 0).Value
        End If
 
    Next i
End Sub

**antonysansh** · 17/05/2016, 10h43

Voila une proposition qui pourrait t'inspirer :

A mettre dans le module de la feuille en question.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim n&
    On Error GoTo fin
    Application.ScreenUpdating = False
    If Target.Column = 1 Then
        With Application.WorksheetFunction
            If .CountIf(ActiveSheet.Columns(Target.Column), Target.Value) > 1 Then
                n = .Match(Target.Value, ActiveSheet.Columns(Target.Column), 0)
                ActiveSheet.Rows(n).Delete Shift:=xlUp
            End If
        End With
    End If
fin:
    Application.ScreenUpdating = True
End Sub

**cocomathis** · 17/05/2016, 10h46

Merci Nordens, j'ai mis ton code dans le code de la feuille mais il ne se passe rien :/

**Nodens_swiss** · 17/05/2016, 10h51

As-tu lance la macro?

Sinon tu peux mettre le code dans Worksheet.change

**jerome.vaussenat** · 17/05/2016, 10h55

Salut,

voici une autre solution.

Par contre si tu veux qu'il se passe un truc, tu ne dois pas coller le code dans un simple module.
Dans l'editeur VBA, à gauche, tu as la liste des feuilles. Fais un double clic sur la feuille qui contient le tableau. Un modulespecifique à la feuille s'affiche. Là tu colles le code. On est sur des macros événementielles (suite à une action de l'utilisateur.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
Private Sub Worksheet_Change(ByVal Target As Range)
    'déclaration de variable
    Dim cpt As Integer
    Const col_a_traiter As Integer = 1 '1 pour colonne A
 
    'on teste si on est bien dans la col à traiter
    If Target.Column = col_a_traiter Then
        'parcourt du tableau vers le haut
        For cpt = Target.Row - 1 To 1 Step -1
            'si on trouve la valeur saisie
            If Cells(cpt, col_a_traiter).Value = Target.Value Then
                'on l'efface
                Cells(cpt, col_a_traiter).ClearContents
                'et on sort de laboucle
                Exit For
            End If
        Next
    End If
End Sub

**jerome.vaussenat** · 17/05/2016, 11h00

Salut,

En regardant les variantes proposées. Il faut voir ce que tu appelle effacer l'ancienne valeur.
Soit on efface simplement la valeur soit on supprime la ligne contenant l'ancienne valeur ...

A préciser.

**cocomathis** · 17/05/2016, 11h09

Merci encore pour votre réactivité, ce forum est vraiment génial

La solution d'Antony est celle qui se rapproche le plus de ce que je veux. En effet Jerome, je souhaite juste effacer la valeur et non supprimer la ligne.

Dans le code d'Antony, ça fait exactement ce que je veux, sauf que ça fonctionne que si je rentre le chiffre dans une cellule plus bas dans la colonne, si je veux remonter, ça ne fonctionne pas. Exemple:

1 est dans A1, je rentre 1 dans A12, pas de soucis, A1 s'efface, mais si par la suite je rentre 1 dans A9, A12 ne s'efface pas. :/

Après c'est de ma faute, je ne l'avais pas demandé dans le sujet :p

En tout cas, encore merci, vous êtes des chefs

**antonysansh** · 17/05/2016, 11h20

Une adaptation :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim n&, rg As Range
    On Error GoTo fin
    Application.ScreenUpdating = False
    If Target.Column = 1 Then
        With Application.WorksheetFunction
            If .CountIf(ActiveSheet.Columns(Target.Column), Target.Value) > 1 Then
                Set rg = ActiveSheet.Columns(1).Find( _
                    What:=Target.Value, After:=Target)
                rg.Clear
            End If
        End With
    End If
fin:
    Application.ScreenUpdating = True
End Sub

Je suis parti du principe que comme on supprime les doublons, il n'y que une valeur ou deux valeurs identiques lors de la saisie.
Dans ce cas un simple .Findaprès la cellule qui vient d'être saisie suffit à trouver la deuxième valeur qui doit ensuite être supprimée.

**jerome.vaussenat** · 17/05/2016, 11h21

Salut,

Et voila

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
Private Sub Worksheet_Change(ByVal Target As Range)
    'déclaration de variable
    Dim cpt As Integer
    Const col_a_traiter As Integer = 1 '1 pour colonne A
    Const lign_max As Integer = 300 'nombre max de lignes dans le tableau
    'on teste si on est bien dans la col à traiter
    If Target.Column = col_a_traiter Then
        'parcourt du tableau vers le haut
        For cpt = lign_max To 1 Step -1
            'si on trouve la valeur saisie sans être sur le ligne qui vient d'être saisie
            If Cells(cpt, col_a_traiter).Value = Target.Value And cpt <> Target.Row Then
                'on l'efface
                Cells(cpt, col_a_traiter).ClearContents
                'et on sort de la boucle
                Exit For
            End If
        Next
    End If
End Sub

En gros, je suis parti sur le faire que ton tableau ai un maximum de 300 lignes (à modifier sur les premières lignes)
Et il efface soit en dessus soit en dessous ...

A tester pour voir si c'est ce que tu veux.

**cocomathis** · 17/05/2016, 11h30

Merci Jerome mais il m'annonce un bug dans la ligne:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Cells(cpt, col_a_traiter).ClearContents

**jerome.vaussenat** · 17/05/2016, 11h33

Definition de bugg ...

Je suis Excel 2010 et je teste en haut, milieu ou fin de tableau et c'est ok.

Quel est le message d'erreur ?

**cocomathis** · 17/05/2016, 11h36

J'ai rien dit, c'est moi qui avait fait une erreur de saisie, je travaillait sur un timer en meme temps et ça a mis le bazar

ça fonctionne parfaitement

Encore un très grand merci à vous tous

**cocomathis** · 26/05/2016, 17h20

salut les amis,

je reviens vers vous car ça ne fonctionne plus

Tout allait tres bien, et je ne sais pas depuis quand il y a un problème. Quand je mets 1 dans une cellule, l'autre ne s'efface plus

voila le code, au cas où quelqu'un pourrait me sauver

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
Option Explicit
 
 
 
 
 
 
 
 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim n&, rg As Range
    On Error GoTo fin
    Application.ScreenUpdating = False
    If Target.Column = 10 Then
        With Application.WorksheetFunction
            If .CountIf(ActiveSheet.Columns(Target.Column), Target.Value) > 1 Then
                Set rg = ActiveSheet.Columns(10).Find( _
                    What:=Target.Value, After:=Target)
                rg.ClearContents
            End If
        End With
    End If
fin:
    Application.ScreenUpdating = True
End Sub
 
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Resume Next
If Not Application.Intersect(Target, Range("L5:l20,l23:l30,l33:l36,l39:l40:l43")) Is Nothing Then 'modifie ton tableau
If Target.Value = "ACTIVE" Then
Target.Value = "EN ATTENTE"
 
Else
Target.Value = "ACTIVE"
End If
 
Else
If Not Intersect(Target, Range("B3:B65556")) Is Nothing Then
UserForm1.TextBox2 = ActiveCell.Value
UserForm1.TextBox1 = ActiveCell.Offset(0, 17).Value
UserForm1.TextBox3 = ActiveCell.Offset(0, 1).Value
UserForm1.TextBox4 = ActiveCell.Offset(0, 2).Value
UserForm1.TextBox5 = ActiveCell.Offset(0, 3).Value
UserForm1.TextBox6 = ActiveCell.Offset(0, 6).Value
UserForm1.TextBox7 = ActiveCell.Offset(0, 5).Value
UserForm1.TextBox8 = ActiveCell.Offset(0, 4).Value
 
UserForm1.Show
Else
 
If Not Intersect(Target, Range("K5:k200")) Is Nothing Then
 
If Target.Value = "TICKET" Then
 
Sheets("Ticket").Range("A6").Value = ActiveCell.Offset(0, -9)
Sheets("Ticket").Range("A9").Value = ActiveCell.Offset(0, -8)
Sheets("Ticket").Range("A14").Value = ActiveCell.Offset(0, -3)
Sheets("Ticket").Range("a7").Value = ActiveCell.Offset(0, 8)
Sheets("Ticket").Range("D2").Value = ActiveCell.Offset(0, -1)
 
 
 
Sheets("Ticket").Visible = True
Sheets("Ticket").Select
 
ActiveSheet.PageSetup.PrintArea = "A1:E18"
    ActiveSheet.PrintOut
 
    Sheets("Ticket").Visible = False
 
    End If
 
End If
End If
End If
 
 
End Sub