Bonjour,
inspiré largement de J. Boisgontier :
Sub GroupColorAdeps() ' permet de repérer facilement les doublons d'une liste (©) JB
Dim Couleurs, MonDico, C, Nocoul, Colonne, Zone, Fin, Lastc, Clé, Zone2
Couleurs = Array(6, 10, 13, 15, 17, 20, 22, 24, 26, 27, 28, 33, 34, 35, 36, 37, 38, 39, 40, 42, 43, 44, 45, 46, 50, 53)
Set MonDico = CreateObject("Scripting.Dictionary")
Colonne = InputBox("Quelle colonne à regrouper par couleur " & Chr(10) & "en lettres, pas de chiffre !!!")
If Colonne = "" Then Exit Sub
If Not ColonneValideColonne) Then Exit Sub
' n'
Fin = Range(Colonne & "65000").End(xlUp).Row
Set Zone = Range(Colonne & "2", Colonne & Fin)
For Each C In Zone
If C <> "" Then MonDico.Item(C.Value) = MonDico.Item(C.Value) + 1
Next C
Lastc = Range("IV4").End(xlToLeft).Column
For Each C In Zone
If C <> "" Then
Nocoul = (Application.Match(C.Value, MonDico.Keys, 0)) Mod UBound(Couleurs)
Range(Cells(C.Row, 1), Cells(C.Row, Lastc)).Interior.ColorIndex = Couleurs(Nocoul)
End If
Next C
[A1].Select
End Sub
Fonction à ajouter
Function ColonneValide (Col) As Boolean
' avec l'aide De Frédéric Sigonneau [frederic.sigonneau@wanadoo.fr]
Col = UCase(Col)
Select Case Len(Col)
Case 1
ColonneValideAdeps = Col Like "[A-Z]"
Case 2
ColonneValideAdeps = Left(Col, 1) Like "[A-Z]" And Right(Col, 1) Like "[A-Z]"
Case 3
ColonneValideAdeps = Left(Col, 1) Like "[A-Z]" And Right(Col, 1) Like "[X-D]"
End Select
End Function
