'////////////////////////////////////////////////////////
'/// Si vous voulez utiliser la procédure directement en
'/// l'appelant par la boîte de macro OU en la lançant à
'/// partir du VBE (Visual Basic Editor), il faut retirer
'/// l'argument Optional dummy As Byte comme suit
'Sub MultiColors()
'////////////////////////////////////////////////////////
Sub MultiColors(Optional dummy As Byte)
Const SEPARATEUR As String = "µ"
Dim S As Worksheet
Dim R As Range
Dim var
Dim i&
Dim j&
Dim k&
Dim A$
Dim Coll As New Collection
Dim Couleurs As Variant
'--- Les couleurs ---
Couleurs = Array(15773696, 12611584, 11324408, 1137349, _
11722949, 65535, 255, 3506516, 10498160, 10086399, _
192, 49407, 37568, 16182238, 13285804)
'--- La feuille et la plage concernées ---
Set S = ActiveSheet
Set R = S.Range("c4:h" & S.[b3].End(xlDown).Row & "")
'--- Effacement des couleurs de la plage ---
R.Interior.Color = xlNone
'--- Création de la collection sans doublon ---
var = R
For i& = 1 To UBound(var, 1)
For j& = 1 To 4
A$ = A$ & var(i&, j&)
Next j&
If A$ <> "" Then
var(i&, 6) = A$
On Error Resume Next
Coll.Add Item:=A$ & SEPARATEUR & CStr(Couleurs(k&)), Key:=A$
If Err = 0 Then
k& = k& + 1
Else
Err.Clear
End If
On Error GoTo 0
A$ = ""
End If
Next i&
'--- Application des couleurs dans la plage ---
For i& = 1 To UBound(var, 1)
For k& = 1 To Coll.Count
A$ = var(i&, 6)
If A$ = Mid(Coll.Item(k&), 1, Len(A$)) Then
Set R = S.Range("c" & i& + 3 & ":f" & i& + 3 & "")
R.Interior.Color = CLng(Mid(Coll.Item(k&), Len(A$) + 2))
End If
Next k&
Next i&
'--- Effacement des zones ---
Set R = S.Range("h4:h" & S.[b3].End(xlDown).Row & "")
R.ClearContents
'--- Création des zones ---
For k& = 1 To Coll.Count
A$ = Coll.Item(k&)
Set R = S.Range("h" & k& + 3 & "")
R.Interior.Color = CLng(Mid(A$, InStr(1, A$, SEPARATEUR) + 1))
R = "Zone" & k&
Next k&
End Sub