Doublons avec cellules en couleurs
mic6259
Messages postés
342
Date d'inscription
Statut
Membre
Dernière intervention
-
mic6259 Messages postés 342 Date d'inscription Statut Membre Dernière intervention -
mic6259 Messages postés 342 Date d'inscription Statut Membre Dernière intervention -
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
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:
- Mettre en couleur les doublons excel
- Excel cellule couleur si condition texte - Guide
- Liste déroulante excel - Guide
- Somme si couleur excel - Guide
- Word et excel gratuit - Guide
- Supprimer les doublons excel - Guide
3 réponses
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...
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...
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
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
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...
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...
