Colorer les doublons avec VBA

[pascal82]

Bonjour à tous,

Je n'arrive pas à colorer les doublons selon l'exemple souhaité en (U2:AB14)
J'ai réalisé un essai en VBA mais ne donne pas le résultat souhaité (le code est dans le module).
J'ai récupéré un code de Mr Boigontier Jacques mais me donne "une erreur d'exécution 13" sans en trouver l'origine (le code est dans le module).

Merci par avance pour vos réponses

 

[pascal82]

Re : Colorer les doublons avec VBA

Bonjour à tous,

J'ai trouvé un code qui me donne le résultat souhaité, même s'il n'est pas optimisé.
Les puristes du VBA peuvent intervenir pour me corriger, je suis preneur de toutes améliorations

Cordialement

Sub MFC()
Dim h As Long
Application.ScreenUpdating = False
Range("K2:R100").ClearContents
    For h = 0 To 12
    Range("K1:R1").Value = Range("A2:H2").Offset(h, 0).Value 'copie des données
GroupColor
    Range("K1:R1").Copy 'copie des résultats
    Range("K2:R2").Offset(h, 0).Select
    ActiveSheet.Paste
Macro1
    Next
Application.ScreenUpdating = True
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub GroupColor() 'code de Mr Boigontier
  Set mondico = CreateObject("Scripting.Dictionary")
  Set champ = Range("K1:R1")
  For Each c In champ
     mondico.Item(c.Value) = mondico.Item(c.Value) + 1
  Next c
  For Each c In champ
    If mondico.Item(c.Value) > 1 Then
      c.Interior.ColorIndex = Application.Match(c.Value, mondico.keys, 0) + 25
    End If
  Next c
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub Macro1()
    Range("K1:R1").Select
    Application.CutCopyMode = False
    With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
End Sub

 

[BOISGONTIER]

Re : Colorer les doublons avec VBA

Bonjour,

Voir PJ

Sub GroupColor()
  couleurs = Array(0, 1, 3, 4, 6, 7, 8, 14, 15, 17, 20, 22, 24, 26, 27, 28, 33, 34, 35, 36, 37, 38, 39, 40, 42, 43, 44, 45, 46, 50, 53)
  For ligne = 1 To 14
    Set champ = Cells(ligne, "k").Resize(, 8)
    Set mondico = CreateObject("Scripting.Dictionary")
    For Each c In champ
      If c <> "" Then mondico.Item(CStr(c.Value)) = mondico.Item(CStr(c.Value)) + 1
    Next c
    champ.Interior.ColorIndex = xlNone
    For Each c In champ
      nocoul = (Application.Match(CStr(c.Value), mondico.keys, 0)) Mod UBound(couleurs)
      If mondico.Item(CStr(c.Value)) > 1 Then c.Interior.ColorIndex = couleurs(nocoul)
    Next c
  Next ligne
End Sub

JB

 

[pascal82]

Re : Colorer les doublons avec VBA

Bonjour,

Un grand merci à vous, la réponse est comme d'habitude parfaite.
Cependant pour parfaire mon éducation, les variables ne sont pas définies et j'aimerai savoir s'il faut les définir en Array en String ou autre.
Encore un grand merci

Cordialement

Voila comment j'ai défini les variables

Dim couleurs As Variant, champ As Variant, mondico As Variant, c As Variant, nocoul As Variant
Dim ligne As Long