Let’s say you have a color, and you want to find the closest match in defined color scheme set. The first problem is defining what closest means. It’s not a simple problem to solve.

There are a number of approaches to this, the simplest being to measure the euclidean distance between two colors in a 3D color space – for example RGB, HSL, HSV etc. Here’s and article that shows how to do that.

However, these mathematical approaches do not really adjust for color perception. Another color model  CIEL*a*b*, has used various algorithms over the years to create better matches to take account of perceived color differences.

Page Content

#### CIEDE2000

This is the latest CIE algorithm (from  wikipedia) for comparing two colors for closeness. It’s a monster

I thought I may as well implement this in VBA , javaScript and google apps script to add to my color function libraries. Here’s the VBA version. Luckily I found (by Gaurav Sharma, Wencheng Wu,Edul N. Dalal) this paper to get me started. The GAS version is at Color Matching in GAS

#### Does it work?

Amazingly, it works very well. In Looking up color table I’ve built up a table of schemes such as Pantone, dulux etc through various web scraping sessions, and now have getting on for 10,000 named colors in that library. To test it, I generate some random colors, then look up the closest in each of the schemes in my color table. Here’s the result – I tried to find a match for the first column of random numbers in all of the color table, and also in each of the individual color schemes. Their names are shown along with their color. Pretty close in all cases. Of course the html color scheme is rather short, but still close results.

#### The gory details

It’s not pretty, but here are the main functions in color match algorithm.
```Public Function cieDe2000(p1 As colorProps, p2 As colorProps) As Double
' calculates the distance between 2 colors using CIEDE200
' see http://www.ece.rochester.edu/~gsharma/cieDe2000/cieDe2000noteCRNA.pdf
Dim c1 As Double, c2 As Double, _
c As Double, g As Double, a1 As Double, b1 As Double, _
a2 As Double, b2 As Double, c1Tick As Double, c2Tick As Double, _
h1 As Double, h2 As Double, dh As Double, dl As Double, dc As Double, _
lTickAvg As Double, cTickAvg As Double, hTickAvg As Double, l50 As Double, sl As Double, _
sc As Double, t As Double, sh As Double, dTheta As Double, kp As Double, _
rc As Double, kl As Double, kc As Double, kh As Double, dlk As Double, _
dck As Double, dhk As Double, rt As Double, dBigH As Double

kp = 25 ^ 7
kl = 1
kc = 1
kh = 1

' calculate c & g values
c1 = Sqr(p1.aStar ^ 2 + p1.bStar ^ 2)
c2 = Sqr(p2.aStar ^ 2 + p2.bStar ^ 2)
c = (c1 + c2) / 2
g = 0.5 * (1 - Sqr(c ^ 7 / (c ^ 7 + kp)))

a1 = (1 + g) * p1.aStar
a2 = (1 + g) * p2.aStar

c1Tick = Sqr(a1 ^ 2 + p1.bStar ^ 2)
c2Tick = Sqr(a2 ^ 2 + p2.bStar ^ 2)

h1 = computeH(a1, p1.bStar)
h2 = computeH(a2, p2.bStar)

' deltas
If (h2 - h1 > 180) Then '1
dh = h2 - h1 - 360
ElseIf (h2 - h1 < -180) Then ' 2
dh = h2 - h1 + 360
Else '0
dh = h2 - h1
End If

dl = p2.LStar - p1.LStar
dc = c2Tick - c1Tick
dBigH = (2 * Sqr(c1Tick * c2Tick) * sIn(toRadians(dh / 2)))

' averages
lTickAvg = (p1.LStar + p2.LStar) / 2
cTickAvg = (c1Tick + c2Tick) / 2

If (c1Tick * c2Tick = 0) Then '3
hTickAvg = h1 + h2

ElseIf (Abs(h2 - h1) <= 180) Then '0
hTickAvg = (h1 + h2) / 2

ElseIf (h2 + h1 < 360) Then '1
hTickAvg = (h1 + h2) / 2 + 180

Else '2
hTickAvg = (h1 + h2) / 2 - 180
End If

l50 = (lTickAvg - 50) ^ 2
sl = 1 + (0.015 * l50 / Sqr(20 + l50))
sc = 1 + 0.045 * cTickAvg
t = 1 - 0.17 * Cos(toRadians(hTickAvg - 30)) + 0.24 * _
Cos(toRadians(2 * hTickAvg)) + 0.32 * _
Cos(toRadians(3 * hTickAvg + 6)) - 0.2 * _

sh = 1 + 0.015 * cTickAvg * t

dTheta = 30 * Exp(-1 * ((hTickAvg - 275) / 25) ^ 2)
rc = 2 * Sqr(cTickAvg ^ 7 / (cTickAvg ^ 7 + kp))
rt = -sIn(toRadians(2 * dTheta)) * rc
dlk = dl / sl / kl
dck = dc / sc / kc
dhk = dBigH / sh / kh
cieDe2000 = Sqr(dlk ^ 2 + dck ^ 2 + dhk ^ 2 + rt * dck * dhk)

End Function```
```Public Function compareColors(rgb1 As Long, rgb2 As Long, _
Optional compareType As eCompareColor = eCompareColor.eccieDe2000) As Double
Dim p1 As colorProps, p2 As colorProps
p1 = makeColorProps(rgb1)
p2 = makeColorProps(rgb2)
Select Case compareType
Case eCompareColor.eccieDe2000
compareColors = cieDe2000(p1, p2)

Case Else
Debug.Assert False

End Select

End Function```
```Private Function computeH(a As Double, b As Double) As Double
If (a = 0 And b = 0) Then
computeH = 0
ElseIf (b >= 0) Then
computeH = Application.WorksheetFunction.Degrees(Application.WorksheetFunction.Atan2(a, b))
Else
computeH = Application.WorksheetFunction.Degrees(Application.WorksheetFunction.Atan2(a, b)) + 360
End If
End Function```
```Private Function rgbToLab(rgbColor As Long) As colorProps
Dim x As Double, y As Double, z As Double, _
p As colorProps

p = rgbToXyz(rgbColor)

x = xyzCIECorrection(p.x / refWhiteX)
y = xyzCIECorrection(p.y / refWhiteY)
z = xyzCIECorrection(p.z / refWhiteZ)

p.LStar = (116 * y) - 16
p.aStar = 500 * (x - y)
p.bStar = 200 * (y - z)

rgbToLab = p
End Function```
```Private Function rgbToXyz(rgbColor As Long) As colorProps
Dim r As Double, g As Double, b As Double, _
p As colorProps

r = xyzCorrection(rgbRed(rgbColor) / 255) * 100
g = xyzCorrection(rgbGreen(rgbColor) / 255) * 100
b = xyzCorrection(rgbBlue(rgbColor) / 255) * 100

p.x = r * 0.4124 + g * 0.3576 + b * 0.1805
p.y = r * 0.2126 + g * 0.7152 + b * 0.0722
p.z = r * 0.0193 + g * 0.1192 + b * 0.9505

rgbToXyz = p
End Function```
```rivate Function xyzCIECorrection(v As Double) As Double
If (v > 0.008856) Then
xyzCIECorrection = (v ^ (1 / 3))
Else
xyzCIECorrection = (7.787 * v) + (16 / 116)
End If
End Function
Private Function rgbToXyz(rgbColor As Long) As colorProps
Dim r As Double, g As Double, b As Double, _
p As colorProps

r = xyzCorrection(rgbRed(rgbColor) / 255) * 100
g = xyzCorrection(rgbGreen(rgbColor) / 255) * 100
b = xyzCorrection(rgbBlue(rgbColor) / 255) * 100

p.x = r * 0.4124 + g * 0.3576 + b * 0.1805
p.y = r * 0.2126 + g * 0.7152 + b * 0.0722
p.z = r * 0.0193 + g * 0.1192 + b * 0.9505

rgbToXyz = p
End Function```
```Private Function xyzCorrection(v As Double) As Double
If (v > 0.04045) Then
xyzCorrection = ((v + 0.055) / 1.055) ^ 2.4
Else
xyzCorrection = v / 12.92
End If
End Function
```

and here’ the test procedure that generated the above

```Private Function getClosestColorMap(ds As cDataSet, target As Long, _
Optional scheme As String = vbNullString) As cCell
Dim dc As cCell, dmin As Double, d As Double, dr As cDataRow
Set dc = Nothing
For Each dr In ds.rows
If (scheme = vbNullString Or dr.value("scheme") = scheme) Then
d = compareColors(target, htmlHexToRgb(dr.value("hex")))
If dc Is Nothing Or d < dmin Then
dmin = d
Set dc = dr.cell("hex")
End If
End If
Next dr
Set getClosestColorMap = dc
End Function```
```Public Sub SeedSomeColors()
Dim r As Range, n As Long, ncells As Long, ds As cDataSet, t As Long, dc As cCell, _
dr As cDataRow, p As colorProps, a As Variant, i As Long
Set r = firstCell(wholeSheet("comparecolors"))
ncells = 30
Application.Calculation = xlCalculationManual
Randomize
' create some random colors to test against
For n = 1 To ncells
With r.Offset(n, 0)
p = makeColorProps(Int((vbWhite - vbBlack + 1) * Rnd + vbBlack))
.Interior.color = p.rgb
.Font.color = p.textColor
.value = p.htmlHex
End With
Next n

' now look in the colortable
Set ds = getcolorMap()

' cycle through various schemes
a = Array("", "pms", "pfh", "dulux", "htm")
For i = LBound(a) To UBound(a)
For n = 1 To ncells
t = r.Offset(n, 0).Interior.color
Set dc = getClosestColorMap(ds, t, CStr(a(i)))
If Not dc Is Nothing Then
With r.Offset(n, 1 + i - LBound(a))
p = makeColorProps(htmlHexToRgb(dc.value))
.value = ds.value(dc.row, "name")
.Interior.color = p.rgb
.Font.color = p.textColor
End With
End If
Next n
Next i

Application.Calculation = xlCalculationAutomatic
ds.tearDown

End Sub```