RGBで最も近い色を特定する関数

LookupNearRGB.bas.vba

Option Explicit

Rem 色特定サンプル
Sub Test_LookupNearRGB()
    Dim r As Long
    
    Rem A列に暫定基準カラーの生成
    Dim baseRGBs As New Collection
    For r = 1 To 8
        Cells(r, 1).Interior.ColorIndex = r
        baseRGBs.Add Cells(r, 1).Interior.Color
    Next
    
    Rem B列にテストカラー設定 ColorIndexを活用する
    For r = 1 To 56
        Cells(r, 2).Interior.ColorIndex = r
    Next
    
    Rem B列のカラーに最も近い色をC列に設定
    For r = 1 To ActiveSheet.UsedRange.Rows.Count
        Cells(r, 3).Interior.Color = LookupRGB(Cells(r, 2).Interior.Color, baseRGBs)
    Next
End Sub

Rem 最も距離が短い（最も近いはずの）色を返す
Function LookupRGB(targetRGB, baseRGBs) As Long
    Dim minDist As Long: minDist = 255 ^ 3
    Dim baseRGB
    For Each baseRGB In baseRGBs
        If minDist > DistanceRGB(targetRGB, baseRGB) Then
            minDist = DistanceRGB(targetRGB, baseRGB)
            LookupRGB = baseRGB
        End If
    Next
End Function

Rem RGBの色間距離を求める関数
Function DistanceRGB(rgb1, rgb2) As Double
    DistanceRGB = Sqr((RgbToRed(rgb1) - RgbToRed(rgb2)) ^ 2 + _
                   (RgbToGreen(rgb1) - RgbToGreen(rgb2)) ^ 2 + _
                   (RgbToBlue(rgb1) - RgbToBlue(rgb2)) ^ 2)
End Function

Public Function RgbToRed(ByVal rgb_value As Long) As Long
    RgbToRed = &HFF& And rgb_value
End Function

Public Function RgbToGreen(ByVal rgb_value As Long) As Long
    RgbToGreen = (&HFF00& And rgb_value) \ 256
End Function

Public Function RgbToBlue(ByVal rgb_value As Long) As Long
    RgbToBlue = (&HFF0000 And rgb_value) \ 65536
End Function

Rem 一般的な三次元空間の点間距離を求める関数
Function Distance(x1, y1, z1, x2, y2, z2) As Double
    Distance = Sqr((x2 - x1) ^ 2 + (y2 - y1) ^ 2 + (z2 - z1) ^ 2)
End Function

きっかけ

Excelで使っているあいまいな色を、特定の色として判定する
https://twitter.com/blacklist_ryu/status/1475310927067357184?s=20

仕組み

三次元空間の点間距離を求めるのに使用する考え方をRGBに置き換えて、もっとも距離が近い＝もっとも色が近いと仮定して特定しています。

特に実用テストはしていないので、使用する場合は各自のデータでテストしてください。

サンプル画像