[EXCEL VBA]Set cell background color as the cell value like #88dd8f in Selection Range

vba

Sub セルから背景色設定()
'
' 選択範囲のそれぞれのセルの値から、そのセル自身に背景色設定 Macro
' cell : "#0fa" "#00ffdd" , "33,44,44" / and "123,212,213" too (^^;> excel vba 2016

    Dim c As Range
    Dim v, vt, vtt As String
    Dim l As Long
    Dim r, g, b As Integer
    Dim reRGB, reSharp6, reSharp3 As Object 'New RegExp
    Dim mc As Object 'MatchCollection
    
    Set reRGB = CreateObject("VBScript.RegExp")
    reRGB.Pattern = "(\d{1,3})\s*,\s*(\d{1,3})\s*,\s*(\d{1,3})"
    reRGB.Global = True
    Set reRGBExcel = CreateObject("VBScript.RegExp")
    reRGBExcel.Pattern = "(\d{1,3})(\d{3})(\d{3})" 'excel misunderstood as number not string....
    reRGBExcel.Global = True
    Set reSharp6 = CreateObject("VBScript.RegExp")
    reSharp6.Pattern = "#([0-9a-fA-FIO]{6})"
    reSharp6.Global = True
    Set reSharp3 = CreateObject("VBScript.RegExp")
    reSharp3.Pattern = "#([0-9a-fA-F])([0-9a-fA-F])([0-9a-fA-F])"
    reSharp3.Global = True
     
 
    For Each c In Selection
        ''c に対する処理
        v = c.Value
        Set mc = reRGB.Execute(v)
        If mc.Count > 0 Then
            r = Val(mc(0).SubMatches(0))
            g = Val(mc(0).SubMatches(1))
            b = Val(mc(0).SubMatches(2))
        Else
            Set mc = reSharp6.Execute(v)
            If mc.Count > 0 Then
                vt = Mid(mc(0).Value, 2, 6)
                vtt = Replace(Replace(vt, "I", "1"), "O", "0")
                v = "&H" & vtt
                If v <> vt Then
                    c.Value = Replace(c.Value, mc(0), "#" & vtt)
                End If
                
                l = Val(v)
                If l < 0 Then
                    'MsgBox " " & v & " ->" & l & " calc error   (;;)" ' #00adb5
                    l = 0
                    l = Val(Mid(v, 1, 4)) * 256 * 256 + Val("&H" & Mid(v, 5, 2)) * 256 + Val("&H" & Mid(v, 7, 2))
                    If l < 0 Then
                         GoTo CONTINUE
                    End If
                End If
            Else
                Set mc = reSharp3.Execute(v)
                If mc.Count > 0 Then
                    l = Val("&H" & mc(0).SubMatches(0) & mc(0).SubMatches(0) _
                    & mc(0).SubMatches(1) & mc(0).SubMatches(1) _
                    & mc(0).SubMatches(2) & mc(0).SubMatches(2))
                Else
                    Set mc = reRGBExcel.Execute(v)
                    If mc.Count > 0 Then
                        r = Val(mc(0).SubMatches(0))
                        g = Val(mc(0).SubMatches(1))
                        b = Val(mc(0).SubMatches(2))
                        GoTo CALC
                    Else
                        GoTo CONTINUE
                    End If
                End If
            End If
            
            r = Int(l / 256 / 256)
            g = Int(l / 256) Mod 256
            b = l Mod 256
        
        End If
CALC:
        c.Interior.Color = RGB(r, g, b)
CONTINUE:
    Next c
End Sub