Completer un bout de code

[vandewinkel]

Salut ts le monde,

j'ai trouvé un bout de code qui est presque ce que je veux, mais j'arrive pas à faire les dernières retouches!!
Pourriez-vous svp m'aider?

Ce que j'essaye de
1) Modifier de sorte à la faire marcher sur plusieur colonne 1,2,3,...
=> mais il ne prends en compte que la dernière colonne ??

2) Ajouter un indice de couleur (mais pas sous forme de macro à executer, plutôt automatique)
=> mettre les valeurs double de la colonne 1 en fond rouge et police jaune
même chose sur la colonne 2,3 ...


Big merci

--------------------------------------------------------------

1)

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim Colonne As Integer
Dim Adresse As String
If Target.Count > 1 Then Exit Sub
If Target.Value = "" Then Exit Sub
'colonne à vérifier
Colonne = 1
Colonne = 2
Colonne = 3
If Target.Column = Colonne Then
Adresse = Columns(Colonne).Find(What:=Target.Value, After:=Target.Offset(1, 0), LookAt:=xlWhole, _
SearchDirection:=xlNext).Address
If Adresse <> Target.Address Then
MsgBox "" & Target & " est en double sur la cellule " & Adresse
End If
End If
End Sub

2)
Sub Test()
IdentifieDoublons Range("w5:w55")
IdentifieDoublons Range("x5:x55")
End Sub



Sub IdentifieDoublons(Plage As Range)
Dim Cell As Range
Dim Un As Collection

Set Un = New Collection

On Error Resume Next

'Boucle sur la plage de cellule
For Each Cell In Plage
'Pour ne pas prendre en compte les cellules vides
If Cell <> "" Then
'Ajoute le contenu de la cellule dans la collection
Un.Add Cell, CStr(Cell)

'Si la procédure renvoie une erreur, cela signifie que l'élément
'existe déjà dans la collection et donc qu'il s'agit d'un doublon.
'Dans ce cas la macro colorie la cellule en vert.
If Err <> 0 Then Cell.Interior.ColorIndex = 4
'Efface toutes les valeurs de l'objet Err.
Err.Clear
End If
Next Cell

Set Un = Nothing
End Sub

 

[Robert]

Re : Completer un bout de code

Bonjour Vandewinkel, bonjour le forum,

Je pense qu'une boucle devrait résoudre ton premier problème :

For Colonne = 1 To 3
    If Target.Column = Colonne Then
        Adresse = Columns(Colonne).Find(What:=Target.Value, After:=Target.Offset(1, 0), LookAt:=xlWhole, _
            SearchDirection:=xlNext).Address
        If Adresse <> Target.Address Then
            MsgBox "" & Target & " est en double sur la cellule " & Adresse
        End If
    End If
Next Colonne

et pour le second point peut-être comme ça, j'ai pas testé...:

If Err <> 0 Then Cell.Interior.ColorIndex = 5 And Cell.Font.ColorIndex = 6

 

[vandewinkel]

Re : Completer un bout de code

Merci Robert, ca marche pour la premeière partie
La seconde parcontre !?! passe pas

Bonjour Vandewinkel, bonjour le forum,

Je pense qu'une boucle devrait résoudre ton premier problème :

For Colonne = 1 To 3
    If Target.Column = Colonne Then
        Adresse = Columns(Colonne).Find(What:=Target.Value, After:=Target.Offset(1, 0), LookAt:=xlWhole, _
            SearchDirection:=xlNext).Address
        If Adresse <> Target.Address Then
            MsgBox "" & Target & " est en double sur la cellule " & Adresse
        End If
    End If
Next Colonne

et pour le second point peut-être comme ça, j'ai pas testé...:

If Err <> 0 Then Cell.Interior.ColorIndex = 5 And Cell.Font.ColorIndex = 6