VBA script to convert NCS to RGB

[Brynolf]

Is there any way to convert NCS (Natural Color System) codes to RGB using Excel VBA?
I would appreciate greatly if someone can provide me with a viable solution using VBA!

//Brynolf

 

[lrobbo314]

How about this?

ncs2rgb.xlsm
	A	B
1	NCS	RGB
2	0300-N	247, 247, 247
3	0500-N	242, 242, 242
4	0502-B	242, 237, 237
5	0502-B50G	237, 242, 242
6	0502-G	242, 237, 237
7	0502-G50Y	240, 242, 237
8	0502-R	242, 237, 237
9	0502-R50B	237, 242, 237
10	0502-Y	242, 237, 237
11	0502-Y20R	242, 241, 237
12	0502-Y50R	242, 240, 237
13	0502-Y80R	242, 238, 237
14	0505-B	242, 230, 230
15	0505-B20G	230, 235, 242
16	0505-B50G	230, 242, 242
17	0505-B80G	230, 242, 235
18	0505-G	242, 230, 230
19	0505-G10Y	231, 242, 230
20	0505-G20Y	233, 242, 230
21	0505-G30Y	234, 242, 230
22	0505-G40Y	235, 242, 230
23	0505-G50Y	236, 242, 230
24	0505-G60Y	237, 242, 230
25	0505-G70Y	239, 242, 230
26	0505-G80Y	240, 242, 230
27	0505-G90Y	241, 242, 230
28	0505-R	242, 230, 230
29	0505-R10B	242, 235, 230
30	0505-R20B	242, 240, 230
31	0505-R30B	240, 242, 230
32	0505-R40B	235, 242, 230
33	0505-R50B	230, 242, 230
34	0505-R60B	230, 242, 235
35	0505-R70B	230, 242, 240
36	0505-R80B	230, 240, 242
37	0505-R90B	230, 235, 242
38	0505-Y	242, 230, 230
39	0505-Y10R	242, 241, 230
40	0505-Y20R	242, 240, 230
41	0505-Y30R	242, 239, 230
42	0505-Y40R	242, 237, 230
43	0505-Y50R	242, 236, 230
44	0505-Y60R	242, 235, 230
45	0505-Y70R	242, 234, 230
46	0505-Y80R	242, 233, 230
47	0505-Y90R	242, 231, 230
48	0507-B	242, 225, 225
49	0507-B20G	225, 232, 242
50	0507-B80G	225, 242, 232
51	0507-G	242, 225, 225
Sheet2

Cell Formulas
Range	Formula
B2:B51	B2	=ncs2rgb(A2)

Public hues As Object

Function ncs2rgb(s As String)
Set hues = CreateObject("Scripting.Dictionary")
hues("r") = 0
hues("y") = 60
hues("g") = 120
hues("b") = 240
hsv = ncs2hsv(s)
ncs2rgb = Join(hsv2rgb(hsv(0), hsv(1), hsv(2)), ", ")
End Function

Function ncs2hsv(st As String)
Dim h As Variant
Dim v As Single
Dim p1 As Single
Dim p2 As Single
Dim frac As Single

st = LCase(st)
v = 100 - Int(Left(st, 2))
s = Int(Mid(st, 3, 2))
h = Right(st, Len(st) - 5)

If Len(h) = 1 Then
    h = hues(h)
Else
    p1 = hues(Right(h, 1))
    p2 = hues(Left(h, 1))
    frac = Int(Mid(h, 2, 2)) * 0.01
    h = Round(p1 * frac + p2 * (1 - frac), 0)
    
End If

ncs2hsv = Array(h, s * 0.01, v * 0.01)
End Function

Function hsv2rgb(h As Variant, s As Variant, v As Variant)
Dim r As Double
Dim g As Double
Dim b As Double
Dim i As Integer
Dim f As Double
Dim p As Double
Dim q As Double
Dim t As Double
Dim hTemp As Double

h = h Mod 360
hTemp = h / 60
i = Application.WorksheetFunction.Floor(hTemp, 1)
f = hTemp - i
p = v * (1 - s)
q = v * (1 - (s * f))
t = v * (1 - (s * (1 - f)))

Select Case i
    Case 0
        r = v
        g = t
        b = p
    Case 1
        r = q
        g = v
        b = p
    Case 2
        r = p
        g = v
        b = t
    Case 3
        r = p
        g = q
        b = v
    Case 4
        r = t
        g = p
        b = v
    Case 5
        r = v
        g = p
        b = q
End Select

hsv2rgb = Array(Round(r * 255, 0), Round(g * 255, 0), Round(b * 255, 0))
End Function

 

[Brynolf]

Thank you very much for your suggestion!
However, regrettably it doesn't quite work out. When I copy/paste VBA code into the VBA editor I get the error response "#NAME?" in the B column.
I'll have to confess that I am by no standards a phantom of VBA coding as such and I yeild to better knowledge, but where should I paste all the code on "Sheet1" or in a separate module in the VBA editor?

Kind regards
Magnus

 

[zero269]

Thank you very much for your suggestion!
However, regrettably it doesn't quite work out. When I copy/paste VBA code into the VBA editor I get the error response "#NAME?" in the B column.
I'll have to confess that I am by no standards a phantom of VBA coding as such and I yeild to better knowledge, but where should I paste all the code on "Sheet1" or in a separate module in the VBA editor?

Kind regards
Magnus

Out of curiosity, I tested this out just now.
I copied the VBA code into a new Standard Module. If you copy the Table Data before declaring the undeclared variables, you'll see those errors you reported due to Column B containing the formulas already.

There were two Variables that weren't declared, so I took a guess and settled on:

For the following Function, I just made it a Variant.

Function ncs2rgb(s As String)
Dim hsv 'Wasn't declared

For this Function, I went with Integer.

Function ncs2hsv(st As String)
Dim s As Integer 'Wasn't declared

After that, the table data was able to complete. I was able to test the two functions as well...briefly.

 

[Brynolf]

Thank you once again for your response I admire your patience with me, but it still doesn't work! I've copied all your inputs and followed your instructions to the best of my knowledge. You see my interpretation below!
- If you still can bare with me, I'd appreciate if you can go through the "Module1" coding and help me to get it right (I've made some minor structural changes )!

Rgds
//Magnus

ncs2rgb.xlsm
	A	B
1	NCS	RGB
2	0300-N	#VALUE!
3	0500-N
4	0502-B
5	0502-B50G
6	0502-G
7	0502-G50Y
8	0502-R
9	0502-R50B
10	0502-Y
11	0502-Y20R
12	0502-Y50R
13	0502-Y80R
14	0505-B
15	0505-B20G
16	0505-B50G
17	0505-B80G
18	0505-G
19	0505-G10Y
20	0505-G20Y
21	0505-G30Y
22	0505-G40Y
23	0505-G50Y
24	0505-G60Y
25	0505-G70Y
26	0505-G80Y
27	0505-G90Y
28	0505-R
29	0505-R10B
30	0505-R20B
31	0505-R30B
32	0505-R40B
33	0505-R50B
34	0505-R60B
35	0505-R70B
36	0505-R80B
37	0505-R90B
38	0505-Y
39	0505-Y10R
40	0505-Y20R
41	0505-Y30R
42	0505-Y40R
43	0505-Y50R
44	0505-Y60R
45	0505-Y70R
46	0505-Y80R
47	0505-Y90R
48	0507-B
49	0507-B20G
50	0507-B80G
51	0507-G
Blad1

Cell Formulas
Range	Formula
B2	B2	=ncs2rgb(A2)

Option Explicit
Public hues As Object

Function ncs2rgb(s As String)

    Dim hsv
    Set hues = CreateObject("Scripting.Dictionary")
    hues("r") = 0
    hues("y") = 60
    hues("g") = 120
    hues("b") = 240
    hsv = ncs2hsv(s)
    ncs2rgb = Join(hsv2rgb(hsv(0), hsv(1), hsv(2)), ", ")

End Function

Function ncs2hsv(st As String)

    Dim h As Variant
    Dim s As Integer
    Dim v, p1, p2, frac As Single
    st = LCase(st)
    v = 100 - Int(Left(st, 2))
    s = Int(Mid(st, 3, 2))
    h = Right(st, Len(st) - 5)
        If Len(h) = 1 Then
        h = hues(h)
            Else
            p1 = hues(Right(h, 1))
            p2 = hues(Left(h, 1))
            frac = Int(Mid(h, 2, 2)) * 0.01
            h = Round(p1 * frac + p2 * (1 - frac), 0)
        End If
    ncs2hsv = Array(h, s * 0.01, v * 0.01)

End Function

Function hsv2rgb(h As Variant, s As Variant, v As Variant)

    Dim r, g, b, i, f, p, q, t, hTemp As Double
    h = h Mod 360
    hTemp = h / 60
    i = Application.WorksheetFunction.Floor(hTemp, 1)
    Application.WorksheetFunction.f
    f = hTemp - i
    p = v * (1 - s)
    q = v * (1 - (s * f))
    t = v * (1 - (s * (1 - f)))
        Select Case i
        Case 0
        r = v
        g = t
        b = p
            Case 1
            r = q
            g = v
            b = p
                Case 2
                r = p
                g = v
                b = t
                Case 3
                r = p
                g = q
                b = v
            Case 4
            r = t
            g = p
            b = v
        Case 5
        r = v
        g = p
        b = q
        End Select
    hsv2rgb = Array(Round(r * 255, 0), Round(g * 255, 0), Round(b * 255, 0))

End Function

 

[FormR]

(I've made some minor structural changes )!

Hi, it looks to me like you've introduced an erroneous line of code in the hsv2rgb() function during that process - try deleting this line Application.WorksheetFunction.f from that function.

 

[Brynolf]

Thank you for the reminder! That resolved the whole issue!
Have a nice one...

//Magnus