Option Explicit
Sub SetColorToCurrent(r As Range)
Dim vColorsArray(1 To 40)
Dim vToolTipArray(1 To 40)
Dim sToolTipText As String
Dim bytColorPos As Byte, i As Byte
'\populate both arrays
vColorsArray(1) = "0"
vToolTipArray(1) = "Black"
vColorsArray(2) = "3399"
vToolTipArray(2) = "Brown"
vColorsArray(3) = "3333"
vToolTipArray(3) = "Olive Green"
vColorsArray(4) = "3300"
vToolTipArray(4) = "Dark Green"
vColorsArray(5) = "663300"
vToolTipArray(5) = "Dark Teal"
vColorsArray(6) = "800000"
vToolTipArray(6) = "Dark Blue"
vColorsArray(7) = "993333"
vToolTipArray(7) = "Indigo"
vColorsArray(8) = "333333"
vToolTipArray(8) = "Gray-80%"
vColorsArray(9) = "80"
vToolTipArray(9) = "Dark Red"
vColorsArray(10) = "66FF"
vToolTipArray(10) = "Orange"
vColorsArray(11) = "8080"
vToolTipArray(11) = "Dark Yellow"
vColorsArray(12) = "8000"
vToolTipArray(12) = "Green"
vColorsArray(13) = "808000"
vToolTipArray(13) = "Teal"
vColorsArray(14) = "FF0000"
vToolTipArray(14) = "Blue"
vColorsArray(15) = "996666"
vToolTipArray(15) = "Blue-Gray"
vColorsArray(16) = "808080"
vToolTipArray(16) = "Gray-50%"
vColorsArray(17) = "FF"
vToolTipArray(17) = "Red"
vColorsArray(18) = "99FF"
vToolTipArray(18) = "Light Orange"
vColorsArray(19) = "CC99"
vToolTipArray(19) = "Lime"
vColorsArray(20) = "669933"
vToolTipArray(20) = "Sea Green"
vColorsArray(21) = "CCCC33"
vToolTipArray(21) = "Aqua"
vColorsArray(22) = "FF6633"
vToolTipArray(22) = "Light Blue"
vColorsArray(23) = "800080"
vToolTipArray(23) = "Violet"
vColorsArray(24) = "969696"
vToolTipArray(24) = "Gray-40%"
vColorsArray(25) = "FF00FF"
vToolTipArray(25) = "Pink"
vColorsArray(26) = "CCFF"
vToolTipArray(26) = "Gold"
vColorsArray(27) = "FFFF"
vToolTipArray(27) = "Yellow"
vColorsArray(28) = "FF00"
vToolTipArray(28) = "Bright Green"
vColorsArray(29) = "FFFF00"
vToolTipArray(29) = "Turquoise"
vColorsArray(30) = "FFCC00"
vToolTipArray(30) = "Sky Blue"
vColorsArray(31) = "663399"
vToolTipArray(31) = "Plum"
vColorsArray(32) = "C0C0C0"
vToolTipArray(32) = "Gray-25%"
vColorsArray(33) = "CC99FF"
vToolTipArray(33) = "Rose"
vColorsArray(34) = "99CCFF"
vToolTipArray(34) = "Tan"
vColorsArray(35) = "99FFFF"
vToolTipArray(35) = "Light Yellow"
vColorsArray(36) = "CCFFCC"
vToolTipArray(36) = "Light Green"
vColorsArray(37) = "FFFFCC"
vToolTipArray(37) = "Light Turquoise"
vColorsArray(38) = "FFCC99"
vToolTipArray(38) = "Pale Blue"
vColorsArray(39) = "FF99CC"
vToolTipArray(39) = "Lavender"
vColorsArray(40) = "FFFFFF"
vToolTipArray(40) = "White"
'\store the tooltips of all color controls
'\located in the "Fill Color" ToolBar
For i = 1 To 40
vToolTipArray(i) = "Fill Color (" & vToolTipArray(i) & ")"
Next
'\get the current color tooltiptex
sToolTipText = CommandBars.FindControl(Id:=1691).TooltipText
'\handle the unique case of "No Fill"
On Error Resume Next
bytColorPos = WorksheetFunction.Match(sToolTipText, vToolTipArray(), 0)
If Err <> 0 Then
On Error GoTo 0
r.Interior.ColorIndex = 0
Exit Sub
End If
'\set the color of range(s)
r.Interior.Color = hexTodec(vColorsArray(bytColorPos))
End Sub
'\convert hex to decimals
Private Function hexTodec(ByVal hex As String) As Double
Dim f As Double
Dim r As Double
Dim B As String
f = 1
r = 0
While Len(hex) > 0
B = Mid(hex, Len(hex), 1)
Select Case B
Case "0" To "9"
r = r + f * Val(B)
Case Else
r = r + f * (10 + Asc(B) - Asc("A"))
End Select
f = f * 16
hex = Left(hex, Len(hex) - 1)
Wend
hexTodec = r
End Function