Doublons avec cellules en couleurs

Fermé
mic6259 Messages postés 342 Date d'inscription mercredi 4 mars 2015 Statut Membre Dernière intervention 11 décembre 2023 - Modifié le 9 juil. 2017 à 14:50
mic6259 Messages postés 342 Date d'inscription mercredi 4 mars 2015 Statut Membre Dernière intervention 11 décembre 2023 - 12 juil. 2017 à 10:25
Bonjour
Je vais essayer d’être claire.

Dans le fichier Classeur1.xlsm, vous avez dans Feuil1 une serie de chiffre allant de A1 a Z99.
Vous avez la macro ci-dessous.Quand vous êtes dans Visual Basic dans Feuil1(Feuil1) vous exécuter la macro.
Avec "a1:j99" çà fonctionne mais quand je fait "a1:t99" la çà ne fonctionne pas.
En sachant que cette macro trouve tous les doubles en donnant une couleur différente sur chaque cellule en double.
https://www.cjoint.com/c/GGjmWbRjQ6f

Sub ColorDoublon()
Dim Lg%, Dico As Object, Plg As Range, c
Lg = Range("A65536").End(xlUp).Row
Set Dico = CreateObject("Scripting.Dictionary")
Set Plg = Range("a1:j99" & Lg) 'à adapter
Plg.Interior.ColorIndex = xlNone

For Each c In Plg
If c <> "" Then Dico.Item(c.Value) = Dico.Item(c.Value) + 1
Next c

For Each c In Plg
If Dico.Item(c.Value) > 1 Then
c.Interior.ColorIndex = Application.Match(c.Value, Dico.keys, 0) + 2
End If
Next c
End Sub

Voila j’espère que çà va aller pour vous.
Cordialement
A voir également:

3 réponses

Mike-31 Messages postés 18318 Date d'inscription dimanche 17 février 2008 Statut Contributeur Dernière intervention 26 avril 2024 5 079
Modifié le 9 juil. 2017 à 15:00
Bonjour,

Déjà place ton code dans un module et non dans les propriétés de ta feuille

clic droit sur l'onglet d'une feuille ou Alt et touche F11
Insertion/Module et colle ce code

Sub Doublon1()
Dim celluleTrouvee As Range
Dim FirstCell As String
If IsEmpty(ActiveCell) Then
MsgBox "Pas de recherche sur une cellule vide."
Exit Sub
End If
FirstCell = ActiveCell.Address
Set celluleTrouvee = Worksheets("Feuil1"). _
Range("A1:T150").Find(What:=ActiveCell. _
Value, After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext)
celluleTrouvee.Activate
If ActiveCell.Address = FirstCell Then
MsgBox "Il n'y a pas de doublon correspondant à cette valeur."
Exit Sub
End If
MsgBox ActiveCell.Address & " est un doublon."
Do While Not (celluleTrouvee Is Nothing)
Set celluleTrouvee = Worksheets("Feuil1"). _
Range("A1:T150").FindNext(ActiveCell)
celluleTrouvee.Activate
If ActiveCell.Address = FirstCell Then
Set celluleTrouvee = Nothing
Exit Do
End If
MsgBox ActiveCell.Address & " est un doublon."
Loop
MsgBox "Fin de recherche."
End Sub

N'oublie pas de supprimer l'ancien code dans les propriétés de ta feuille

A+
Mike-31

Je suis responsable de ce que je dis, pas de ce que tu comprends...
1
mic6259 Messages postés 342 Date d'inscription mercredi 4 mars 2015 Statut Membre Dernière intervention 11 décembre 2023 1
11 juil. 2017 à 07:27
Merci beaucoup.
Mais ce n'est pas ce que je recherche,les cellules en doubles doivent être affichés en couleur comme dans la pièce jointe.
Cordialement
0
Mike-31 Messages postés 18318 Date d'inscription dimanche 17 février 2008 Statut Contributeur Dernière intervention 26 avril 2024 5 079
Modifié le 11 juil. 2017 à 09:26
Re,

Il n'a jamais été question de mettre les doublons en couleur dans la demande mais d'étendre la plage à surveiller
"Avec "a1:j99" çà fonctionne mais quand je fait "a1:t99" la çà ne fonctionne pas"
mais comme le manque de clarté dans la demande me vaut un -1
deux lignes dans le code sont simplement à modifier, mais je n'irais pas plus loin
Cordialement

A+
Mike-31

Je suis responsable de ce que je dis, pas de ce que tu comprends...
0
mic6259 Messages postés 342 Date d'inscription mercredi 4 mars 2015 Statut Membre Dernière intervention 11 décembre 2023 1
12 juil. 2017 à 10:25
Bonjour
On ce croirait au patronage et bien moi je vous met -2 pour votre aide
Bonne journée
0