Background colour in RGB-scale matching with values.

[FloFlo]

Hi all,

I am working on a matrix consisting of multiple names matched to values. I would like to give everyone a specific RGB colour value (on different sheet). This way, one can easily recognize one another by colour (in addition to names and values in the cell).
At this moment I have a working code - with the regular 56-colour index - and I would like to change this to RBG scale.

Input:

Name	Colour
A	255,0,0
B	0,255,0
C	0,0,255

<tbody>
</tbody>

Desired result(font is in colour instead of background as I was unable to process this in this message). NB. real matrix is larger.

A	C	B
B	A	C
C	B	A

<tbody>
</tbody>

How can I change this code so that the interior colour will change on the basis of a given rgb value?

Sub Newcols(nRng As Range)Dim rw As Long, Ac As Long, n As Long, fCol As Long
Dim Rng As Range, Dic As Object, Dn As Range
With Sheets("Sheet3")
    Set Rng = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
End With
Set Dic = CreateObject("scripting.dictionary")
    For Each Dn In Rng: Dic(Dn.Value) = Dn.Offset(, 1).Value: Next Dn
For Ac = 1 To nRng.Columns.Count
    For rw = 2 To nRng.Rows.Count Step 2
        
        Select Case Dic(nRng(rw, Ac).Value)
            Case 2, 6, 15, 19, 20, 22, 24, 27, 34, 35, 36, 37, 38, 39, 40, 43, 44, 45, 46, 51, 52: fCol = 1
            Case Else: fCol = 2
        End Select
        nRng(rw, Ac).Interior.ColorIndex = Dic(nRng(rw, Ac).Value)
        nRng(rw + 1, Ac).Interior.ColorIndex = Dic(nRng(rw, Ac).Value)
        nRng(rw, Ac).Font.ColorIndex = fCol
        nRng(rw + 1, Ac).Font.ColorIndex = fCol
    Next rw
Next Ac
nRng.Font.Bold = True
End Sub

I hope I made myself clear enough, thanks in advance!

 

[nemmi69]

A simple example of setting RGB background

Sub SetBackGround()Dim Rrng    As Integer
Dim Grng    As Integer
Dim Brng    As Integer


Rrng = Range("B1").Value
Grng = Range("B2").Value
Brng = Range("B3").Value


'set background
Range("A5").Interior.Color = RGB(Rrng, Grng, Brng)
End Sub

 

[FloFlo]

Hi Nemmi,
Thanks for your response, although, as I am pretty new to this, I don't really know how to implement your code into my previoulsy stated code (a piece of code I got from Mike via this forum).

 

[nemmi69]

I am not totally sure how your code is working. Basically where it gets the RGB values from . What you need to do to use my bit of code is instead of coming from a spreadsheet

Rrng = Range("B1").Value
Grng = Range("B2").Value
Brng = Range("B3").Value

You will need to supply the values for R (Rrng) G (Grng) and B (Brng)

[COLOR=#333333]Range("A5").Interior.Color = RGB(Rrng, Grng, Brng)
[/COLOR]

Is the direct way to set the RGB colour for background.

 

[Marcelo Branco]

See if this example helps

Input table in Sheet2 columns A:B

	A​	B​
1​	Name​	Colour​
2​	A​	255,0,0​
3​	B​	0,255,0​
4​	C​	0,0,255​

<tbody>
</tbody>

Data in Sheet1 (before macro)

	A​	B​	C​
1​	Header1​	Header2​	Header3​
2​	A​	C​	B​
3​	B​	A​	C​
4​	C​	B​	A​

<tbody>
</tbody>

Macro

Sub aTest()
    Dim dic As Object, rCell As Range
    
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = vbTextCompare
    
    With Sheets("Sheet2")
        For Each rCell In .Range("A2:A" & .Cells(Rows.Count, "A").End(xlUp).Row)
            dic(rCell.Value) = Split(rCell.Offset(, 1), ",")
        Next rCell
    End With
    
    With Sheets("Sheet1")
        For Each rCell In .Range("A2:C" & .Cells(.Rows.Count, "A").End(xlUp).Row)
            rCell.Interior.Color = RGB(dic(rCell.Value)(0), dic(rCell.Value)(1), dic(rCell.Value)(2))
            rCell.Font.Color = vbWhite
        Next rCell
    End With
End Sub

After macro

	A​	B​	C​
1​	Header1​	Header2​	Header3​
2​	A​	C​	B​
3​	B​	A​	C​
4​	C​	B​	A​

<tbody>
</tbody>

M.

 

[nemmi69]

Quick question - Can I assume that the number of names will change?

 

[Fluff]

Another option

Sub Newcols(nRng As Range)
Dim rw As Long, Ac As Long, n As Long, fCol As Long, sp As Variant
Dim Rng As Range, Dic As Object, Dn As Range
With Sheets("Sheet3")
    Set Rng = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
End With
Set Dic = CreateObject("scripting.dictionary")
    For Each Dn In Rng: Dic(Dn.Value) = Dn.Offset(, 1).Value: Next Dn
For Ac = 1 To nRng.Columns.Count
    For rw = 2 To nRng.Rows.Count Step 2
        sp = Split(Dic(nRng(rw, Ac).Value), ",")
        nRng(rw, Ac).Resize(2).Interior.ColorIndex = RGB(sp(0), sp(1), sp(2))
        nRng(rw, Ac).Resize(2).Font.Color = TextColorToUse(nRng(rw, Ac).Interior.Color)
    Next rw
Next Ac
nRng.Font.Bold = True
End Sub
Function TextColorToUse(BackColor As Long) As Long
'  This function returns the color to use for
'  text to make it readable on a dark background
'  Code by Rick Rothstein
  Dim Luminance As Long
  Luminance = 77 * (BackColor Mod &H100) + _
              151 * ((BackColor \ &H100) Mod &H100) + _
              28 * ((BackColor \ &H10000) Mod &H100)
  '  Default value of TextColorToUse is 0-Black, set
  '  it to White if the Luminance is less than 32640
  If Luminance < 32640 Then TextColorToUse = vbWhite
End Function

 

[nemmi69]

so far I have this to collect the settings

Dim LastRowNo As Long
Dim RngArray() As String


Sub CollectRGB4Name()
Dim RngString As String
Dim RGBarray() As String
Dim RngLoop As Long


'First row 7, first col A


LastRowNo = Range("A65536").End(xlUp).Row
ReDim RngArray(3, LastRowNo - 7)
 
 For RngLoop = 7 To LastRowNo
    'collect RGB and split to array
    RngString = Range("A" & RngLoop).Offset(0, 1).Value
    RGBarray = Split(RngString, ",")
    RngArray(0, RngLoop - 7) = RGBarray(0)
    RngArray(1, RngLoop - 7) = RGBarray(1)
    RngArray(2, RngLoop - 7) = RGBarray(2)
    'set name
    RngArray(3, RngLoop - 7) = Range("A" & RngLoop).Value
 Next RngLoop


'test
' For RngLoop = 7 To LastRowNo
'    Range("H" & RngLoop).Value = RngArray(0, RngLoop - 7)
'    Range("I" & RngLoop).Value = RngArray(1, RngLoop - 7)
'    Range("J" & RngLoop).Value = RngArray(2, RngLoop - 7)
'    Range("K" & RngLoop).Value = RngArray(3, RngLoop - 7)
'Next RngLoop
End Sub

So if you check a cell against the range you can set the colour. You will have to loop through the array (0 to x)

If  RngArray(3, x) = Range("A" & RngLoop).Value then
      [COLOR=#574123]Range("A5").Interior.Color = RGB([/COLOR]RngArray(0, x) [COLOR=#574123], [/COLOR]RngArray(1, x) [COLOR=#574123], [/COLOR]RngArray(2, x) [COLOR=#574123])[/COLOR]
endif

 

[nemmi69]

I used a fixed range for it to compare

Sub SetBackground2()
Dim ColLoop As Long
Dim RowLoop As Long
Dim RngLoop As Long


'7 first row, E (5) first col


For ColLoop = 5 To 7
    For RowLoop = 7 To 9
        For RngLoop = 0 To 2
            If Range(Cells(RowLoop, ColLoop).Address).Value = RngArray(3, RngLoop) Then
                Range(Cells(RowLoop, ColLoop).Address).Interior.Color = RGB(RngArray(0, RngLoop), RngArray(1, RngLoop), RngArray(2, RngLoop))
            End If
        Next RngLoop
    Next RowLoop
Next ColLoop
End Sub

 

[FloFlo]

Thank you all.
You guys seriously made my day!