VBA課題002「最も近い色を見つけよう！」回答コード

Excel・VBA総合コミュニティ「Excel-Fun.xls*」にて毎月出題される、
VBAの問題に対する私の回答ソースコードを掲載いたします。

今回掲載するコードは第2回課題共有会の課題でもあった、
「最も近い色を見つけよう！」問題です。

今回も読みやすさ重視で書いてみましたので、
よろしければご参考ください(´∀｀)

課題の内容

VBAのカラー定数一覧表を元に、
着色された任意の色について最も近いカラー定数を見つけるお題です！

詳細は下記リンク内にある「課題説明」シートをご確認ください。

せっかくなので回答を見る前に皆さんも挑戦してみましょう。

一度自分が作ってから他の人のコードを見ることで、
学習効果が何倍にも高まります。

完成させなくても、出来る範囲で解くだけでも十分効果がありますので、
是非ともトライしてみてください！

課題共有会とは

ExcelVBAに関する1つのお題にみんなで回答し、
各自のコードを解説しあう勉強会です。

他者のコードを見る機会が少ないVBAユーザーにとって、
いろいろな手法・記法に触れることができる貴重な機会です。

もちろん聞き専での参加もできますので、
ご興味がある方はコミュニティを覗いてみてください。

今回の「最も近い色を見つけよう！」に対する私以外の回答コードも公開されています。

これだけたくさんの方のソースコードを見れる機会はなかなかないと思いますので、
是非ともVBAの勉強にお役立ていただければと思います。

◇ 「最も近い色を見つけよう！」の課題ファイルはこちら
Discord：★出題【VBA】#002 最も近い色を見つけよう！

◇ 「最も近い色を見つけよう！」への回答集はこちら
Discord：☆回答【VBA】#002 最も近い色を見つけよう！

※上記はDiscord参加済みの方用のURLです
　未参加の方は下記からご参加ください！
www.limecode.jp

課題の回答ファイル

実際の回答ファイルはこちらをご覧ください。
(和風スパ)【VBA】002_最も近い色を見つけよう！.xlsm

ソースコード

クラスモジュール：ClassRGB操作

Option Explicit

Private リンクするセル_ As Range
Private リンクする図形_ As Shape
Public is文字色をリンクする As Boolean

Private RGB_ As Long
Private R_ As Long
Private G_ As Long
Private B_ As Long

' 書込プロパティ
Property Let RGB(代入値 As Long)
    RGB_ = 代入値
    R_ = RGB_ Mod 256
    G_ = Int(RGB_ / 256) Mod 256
    B_ = Int(RGB_ / 256 / 256)
    
    Call リンクするオブジェクトを着色する
End Property
Property Let R(代入値 As Long)
    R_ = 代入値
    RGB_ = VBA.RGB(R_, G_, B_)
    Call リンクするオブジェクトを着色する
End Property
Property Let G(代入値 As Long)
    G_ = 代入値
    RGB_ = VBA.RGB(R_, G_, B_)
    Call リンクするオブジェクトを着色する
End Property
Property Let B(代入値 As Long)
    B_ = 代入値
    RGB_ = VBA.RGB(R_, G_, B_)
    Call リンクするオブジェクトを着色する
End Property
Property Set リンクするセル(代入値 As Range)
    Set リンクするセル_ = 代入値
    If is文字色をリンクする Then
        RGB = リンクするセル_.Font.Color
    Else
        RGB = リンクするセル_.Interior.Color
    End If
End Property
Property Set リンクする図形(代入値 As Shape)
    Set リンクする図形_ = 代入値
    If is文字色をリンクする Then
        RGB = リンクする図形_.TextFrame.Characters.Font.Color
    Else
        RGB = リンクする図形_.Fill.ForeColor.RGB
    End If
End Property

Sub リンクするオブジェクトを着色する()

    If Not リンクするセル_ Is Nothing Then
        If is文字色をリンクする Then
            リンクするセル_.Font.Color = RGB_
        Else
            リンクするセル_.Interior.Color = RGB_
        End If
    End If
        
    If Not リンクする図形_ Is Nothing Then
        If is文字色をリンクする Then
            リンクする図形_.TextFrame.Characters.Font.Color = RGB_
        Else
            リンクする図形_.Fill.ForeColor.RGB = RGB_
        End If
    End If
    
End Sub

' 読取プロパティ
Property Get RGB() As Long
    RGB = RGB_
End Property
Property Get RGBテキスト() As String
    RGBテキスト = R_ & "," & G_ & "," & B_
End Property
Property Get G() As Long
    G = G_
End Property
Property Get R() As Long
    R = R_
End Property
Property Get B() As Long
    B = B_
End Property
Property Get リンクするセル() As Range
    Set リンクするセル = リンクするセル_
End Property
Property Get リンクする図形() As Shape
    Set リンクする図形 = リンクする図形_
End Property

シートモジュール：WS近似カラー検索

Option Explicit

' セルアドレス
Property Get Cell対象カラー() As Range
    Set Cell対象カラー = Range("B2")
End Property
Property Get Cell対象カラーRGBテキスト() As Range
    Set Cell対象カラーRGBテキスト = Range("C2")
End Property
Property Get Cell対象カラーR() As Range
    Set Cell対象カラーR = Range("D2")
End Property
Property Get Cell対象カラーG() As Range
    Set Cell対象カラーG = Range("E2")
End Property
Property Get Cell対象カラーB() As Range
    Set Cell対象カラーB = Range("F2")
End Property
Property Get Area対象カラーRGB() As Range
    Set Area対象カラーRGB = Range("D2:F2")
End Property
Property Get DataRangeカラー定数一覧() As Range
    Set DataRangeカラー定数一覧 = Me.AutoFilter.Range.Offset(1) _
        .Resize(Me.AutoFilter.Range.Rows.Count - 1)
End Property
Property Get Cell最近似カラー() As Range
    Set Cell最近似カラー = DataRangeカラー定数一覧.Cells(1, CNo近似カラー検索.カラー)
End Property
Property Get Cell最近似XlrgbColor定数() As Range
    Set Cell最近似XlrgbColor定数 = DataRangeカラー定数一覧.Cells(1, CNo近似カラー検索.XlRgbColor定数)
End Property
Property Get Cell最近似ColorConstants定数() As Range
    Set Cell最近似ColorConstants定数 = DataRangeカラー定数一覧.Cells(1, CNo近似カラー検索.ColorConstants定数)
End Property
Property Get SortKey近似スコア() As Range
    Set SortKey近似スコア = Cells(1, CNo近似カラー検索.近似スコア)
End Property

' RGB値の直接取得・代入
Property Get 対象RGB値() As Long
    対象RGB値 = Cell対象カラー.Interior.Color
End Property
Property Let 対象RGB値(代入値 As Long)
    Cell対象カラー.Interior.Color = 代入値
    Call 対象カラーセルのRGB値を計算して表示する
End Property

' RGB値の計算・表示
Private Sub 対象カラーセルのRGB値を計算して表示する()

    With New ClassRGB操作
        Set .リンクするセル = Cell対象カラー
        Cell対象カラーR = .R
        Cell対象カラーG = .G
        Cell対象カラーB = .B
        DataRangeカラー定数一覧.Columns(1).Interior.Color = .RGB
    End With

End Sub

' セルの編集時
Private Sub Worksheet_Change(ByVal Target As Range)

    Call エクセルの自動更新を停止する(False, False, True)

    If Not Intersect(Target, Area対象カラーRGB) Is Nothing Then
        
        With New ClassRGB操作
            Set .リンクするセル = Cell対象カラー
            .R = Cell対象カラーR
            .G = Cell対象カラーG
            .B = Cell対象カラーB
            DataRangeカラー定数一覧.Columns(1).Interior.Color = .RGB
        End With
    
    End If

    Call エクセルの自動更新を開始する

End Sub

' ダブルクリック時
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim R As Long: R = Target.Row
    Dim C As Long: C = Target.Column
    Dim Adrs As String: Adrs = Target.Address(False, False)
    
    If C = CNo近似カラー検索.カラー _
    And R >= DataRangeカラー定数一覧.Row Then
        
        Call ★学習データをセットする(R)
        Cancel = True
        
    End If

End Sub

標準モジュール：Pr_近似色カラー定数の取得

Option Explicit

Public Enum CNo近似カラー検索
    対象カラー = 1
    カラー
    RGBテキスト
    R
    G
    B
    Max
    Min_Max
    Min
    近似スコア
    差_R
    差_G
    差_B
    差_MAX
    差_Min_Max
    カラー名称
    XlRgbColor定数
    ColorConstants定数
End Enum

' 近似カラーの取得
Function Get近似カラー定数(RGB値 As Long) As Long

    With WS近似カラー検索
        .対象RGB値 = RGB値
        .DataRangeカラー定数一覧.Sort .SortKey近似スコア
        Get近似カラー定数 = WS近似カラー検索.Cell最近似カラー.Interior.Color
    End With

End Function

' 近似カラーの取得
Function Get近似カラー定数名(RGB値 As Long) As String

    With WS近似カラー検索
        .対象RGB値 = RGB値
        .DataRangeカラー定数一覧.Sort .SortKey近似スコア
        Get近似カラー定数名 = IIf(WS近似カラー検索.Cell最近似ColorConstants定数.Value <> "" _
                                , WS近似カラー検索.Cell最近似ColorConstants定数.Value _
                                , WS近似カラー検索.Cell最近似XlrgbColor定数.Value)
    End With

End Function

標準モジュール：Pr_学習データの生成

Sub ★テスト色を乱数生成する()

    Call Get近似カラー定数(RGB(Fx.RandBetween(0, 255), Fx.RandBetween(1, 255), Fx.RandBetween(1, 255)))

End Sub

Sub ★学習データをセットする(R_取込 As Long)
    
    Dim R1st検索シート As Long: R1st検索シート = WS近似カラー検索.DataRangeカラー定数一覧.Row
    
    Dim R_出力 As Long
    R_出力 = GetRLast(WS近似カラー検索) + 1
    
    Intersect(WS近似カラー検索.DataRangeカラー定数一覧, WS近似カラー検索.Rows(R_取込)).Copy _
        WS近似カラー検索.Cells(R_出力, 1)
    WS近似カラー検索.Cells(R_出力, CNo近似カラー検索.RGBテキスト) _
        = WS近似カラー検索.Cells(R_出力, CNo近似カラー検索.RGBテキスト) & "ダミー"
    WS近似カラー検索.Cells(R_出力, CNo近似カラー検索.RGBテキスト).Resize(1, 4).Font.Color = RGB(255, 0, 0)
    
    WS近似カラー検索.Cells(R_出力, CNo近似カラー検索.R) = WS近似カラー検索.Cell対象カラーR
    WS近似カラー検索.Cells(R_出力, CNo近似カラー検索.G) = WS近似カラー検索.Cell対象カラーG
    WS近似カラー検索.Cells(R_出力, CNo近似カラー検索.B) = WS近似カラー検索.Cell対象カラーB
    
    WS近似カラー検索.DataRangeカラー定数一覧.Sort WS近似カラー検索.SortKey近似スコア
    
End Sub

標準モジュール：Ut_汎用関数

Option Explicit

' WorksheetFunctionの短縮取得
Function Fx() As WorksheetFunction
    Set Fx = WorksheetFunction
End Function

' 自動更新の停止
Sub エクセルの自動更新を停止する(ブック計算をOFF As Boolean _
    , Optional 画面更新をOFF As Boolean = True, Optional イベントをOFF As Boolean = True _
    , Optional カーソルをOFF As Boolean = True)
    With Application
        If ブック計算をOFF Then .Calculation = xlCalculationManual
        If 画面更新をOFF Then .ScreenUpdating = False
        If イベントをOFF Then .EnableEvents = False
        If カーソルをOFF Then .Cursor = xlWait
    End With
End Sub

' 自動更新の開始
Function エクセルの自動更新を開始する()
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
        .EnableEvents = True
        .StatusBar = False
        .DisplayAlerts = True
        .Cursor = xlDefault
    End With
    ' 合わせて検索オプションを部分一致に設定
    Call Cells.Find("", lookat:=xlPart)
End Function

' 最終行の取得
Function GetRLast(指定オブジェクト As Variant, Optional ByVal C As Long = -1) As Long

    ' 渡されたオブジェクトからセル範囲を取得
    Dim 対象セル範囲 As Range
    Select Case TypeName(指定オブジェクト)
    Case "Range"
        Set 対象セル範囲 = 指定オブジェクト
    Case "Worksheet"
        Set 対象セル範囲 = 指定オブジェクト.UsedRange
    Case "AutoFilter", "ListObject"
        Set 対象セル範囲 = 指定オブジェクト.Range
    Case Else
        Err.Raise 1000, , "対象外のオブジェクト「" & TypeName(指定オブジェクト) & "」が指定されました。"
    End Select
    
    ' エリアの最終行を取得
    GetRLast = 対象セル範囲.Rows.Count + 対象セル範囲.Row - 1
    
    ' 列が指定されていればその列の入力最終行を取得
    If C <> -1 Then
        Do While 対象セル範囲.Worksheet.Cells(GetRLast, C) = ""
            GetRLast = GetRLast - 1
            If GetRLast < 対象セル範囲.Row Then
                GetRLast = 0
                Exit Function
            End If
        Loop
    End If
End Function

' 値のコピー
Sub 値をコピーする(ペースト基準セル As Range, コピー基準セルまたはエリア As Range _
    , Optional ブロック高 As Long = -1, Optional ブロック幅 As Long = -1)
    
    ' ◇ ブロックサイズ省略時はコピーエリアのサイズを取得
    If ブロック高 = -1 Then ブロック高 = コピー基準セルまたはエリア.Rows.Count
    If ブロック幅 = -1 Then ブロック幅 = コピー基準セルまたはエリア.Columns.Count
    
    ' 値をコピー
    ペースト基準セル.Resize(ブロック高, ブロック幅).Value = コピー基準セルまたはエリア.Resize(ブロック高, ブロック幅).Value

End Sub

コードの解説

① 近似色の検索

まずは近似色を探している部分ですが、こちらはストレートな処理で
「近似スコアでソートして最小値＝最近似の色を取得」しています。

RGB値を取得・計算するコードを簡単に書けるように、
RGB計算を補助するクラスを作ってコードを整理整頓してみました。

このクラスを使うと、

Option Explicit

Public clsRGBテスト As New ClassRGB操作 ' ← テスト用にPublicインスタンスを生成

Sub RGBクラステスト()
    
    clsRGBテスト.RGB = Selection.Interior.Color
    
    Debug.Print clsRGBテスト.R
    Debug.Print clsRGBテスト.G
    Debug.Print clsRGBテスト.B
    ' ↑ RGB値に代入するとR、G、Bそれぞれの値が裏で計算されている
    
    clsRGBテスト.R = 200
    Debug.Print clsRGBテスト.RGBテキスト
    ' ↑ Rを200にするなど変更も可能。RGB値が連動して変更される    

    Set clsRGBテスト.リンクするセル = WS近似カラー検索.Cell対象カラー
    ' ↑クラスをセルとリンクさせることもできる

    Debug.Print clsRGBテスト.RGBテキスト
    ' リンクしたセルの背景色が自動でセットされている

    clsRGBテスト.R = 200
    clsRGBテスト.G = 100
    clsRGBテスト.B = 150
    ' ↑ クラスのR、G、B値をいじると、セルの色が連動して変わる

End Sub

こんな風にRGB値を直感的にいじることができるようになります。

これを使うことで、RGB操作系のコードやChangeイベントの内容が
スッキリしたコードにできているところを見てみてください。

あとはシートモジュールの記載ですが、

Property Get Cell対象カラー() As Range
    Set Cell対象カラー = Range("B2")
End Property

こんな風にProperty Get プロシージャで固定セルを定義することで、
近似カラーシートのB2セルを以下のように書けるようにしています。

WS近似カラー検索.Cell最近似カラー

　
「シートオブジェクト名.定義したプロパティ名」で各セルを参照でき、
読むのも書くのも楽になっているのがわかると思います。

今回のように他ブックが登場しないマクロである場合はこの方法が活用できますので、
気に入ったら採用してみてください。

近似スコアの計算方法と学習

さて今回の課題の面白いポイントは「何をもって似た色とするか」です。

いろいろな方がいろいろな方法で色の近似を取っていますので、
是非とも皆さんの手法を眺めてみてください。

◇ 「最も近い色を見つけよう！」への回答集はこちら
Discord：☆回答【VBA】#002 最も近い色を見つけよう！

※上記はDiscord参加済みの方用のURLです
　未参加の方は下記からご参加ください！
www.limecode.jp

さて私の方法はというと、
とりあえずはRGBを3次元と見立てた距離でやってみました。

√(R - R')² + (G - G')² + (B - B')²、いわゆるユークリッド距離ですね。

しかしこれやってみるとわかるんですが、
全然違う色を持ってくることが多々あるんですよね(´∀｀;)

RGB値自体が正確には3次元空間ではない上に、
例えば「R、G、Bのうち最も高い値が明るさ(明度)になっている」など、
色ならではの特性もあったようです。

そこで取った策として、

• 明らかにもっと近い色がある場合は現在の色をそのカラー定数の最近似色として記録(学習)させる
• しかしその色はカラー定数ではないので、その色が選ばれた場合は対応するカラー定数が選ばれたものとする

という、ダミーカラー定数の学習という形で対応しました。
　

↑実際は(252,20,71)なんだけど登録上は(255,0,0)のカラーを学習させることで、
今後付近の色をこの色に近似してくれるようになります。

※ このアイデアはさくたん様より教えていただきました。
具体的な手法を画像付きで解説してくださっていますので、
興味がある方は回答スレッドを見に行ってみてください。

　
流行りの機械学習ではなく、機械的に人間が手動で学習させた力業ですが、
割と近似精度を高めることが出来たんじゃないかと思います。

おまけ：カラー定数偏りすぎ問題

この課題をやっていて思ったのですが、カラー定数偏りすぎなんですよ笑

こんな風に全然似た色がない領域もありますし↓

かと思えばこんな風に選びたい放題な領域もあります↓

定数設定された方、アイボリーというかクリーム色というか、
そのあたりの薄い黄色好きすぎじゃないですかね？笑

レモンシフォン、パパイヤホイップ、ブランシュアーモンド
とかそんなに薄い黄色をたくさんいただいても使いこなせないんですが。。。笑

まあ別に何かに困るということはないんですが、
なんとなく気になってしまったのでこちらに言及して本記事を締めました(´∀｀;)