Background colour in RGB-scale matching with values.

F

FloFlo

New Member
Joined
Jun 20, 2018
Messages
12
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:
[TABLE="width: 500"]
<tbody>[TR]
[TD]Name[/TD]
[TD]Colour[/TD]
[/TR]
[TR]
[TD]A[/TD]
[TD]255,0,0[/TD]
[/TR]
[TR]
[TD]B[/TD]
[TD]0,255,0[/TD]
[/TR]
[TR]
[TD]C[/TD]
[TD]0,0,255[/TD]
[/TR]
</tbody>[/TABLE]

Desired result(font is in colour instead of background as I was unable to process this in this message). NB. real matrix is larger.
[TABLE="width: 500"]
<tbody>[TR]
[TD]A[/TD]
[TD]C[/TD]
[TD]B[/TD]
[/TR]
[TR]
[TD]B[/TD]
[TD]A[/TD]
[TD]C[/TD]
[/TR]
[TR]
[TD]C[/TD]
[TD]B[/TD]
[TD]A[/TD]
[/TR]
</tbody>[/TABLE]

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

Code: 
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!
 

Excel Facts

What did Pito Salas invent?
Pito Salas, working for Lotus, popularized what would become to be pivot tables. It was released as Lotus Improv in 1989.
Sort by date Sort by votes
A simple example of setting RGB background

Code: 
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
 
Upvote 0
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).
 
Upvote 0
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
Code: 
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)

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


Is the direct way to set the RGB colour for background.
 
Last edited:
Upvote 0
See if this example helps

Input table in Sheet2 columns A:B

[TABLE="class: grid"]
<tbody>[TR]
[TD="bgcolor: #DCE6F1"][/TD]
[TD="bgcolor: #DCE6F1"]
A​
[/TD]
[TD="bgcolor: #DCE6F1"]
B​
[/TD]
[/TR]
[TR]
[TD="bgcolor: #DCE6F1"]
1​
[/TD]
[TD]
Name​
[/TD]
[TD]
Colour​
[/TD]
[/TR]
[TR]
[TD="bgcolor: #DCE6F1"]
2​
[/TD]
[TD]
A​
[/TD]
[TD]
255,0,0​
[/TD]
[/TR]
[TR]
[TD="bgcolor: #DCE6F1"]
3​
[/TD]
[TD]
B​
[/TD]
[TD]
0,255,0​
[/TD]
[/TR]
[TR]
[TD="bgcolor: #DCE6F1"]
4​
[/TD]
[TD]
C​
[/TD]
[TD]
0,0,255​
[/TD]
[/TR]
</tbody>[/TABLE]


Data in Sheet1 (before macro)

[TABLE="class: grid"]
<tbody>[TR]
[TD="bgcolor: #DCE6F1"][/TD]
[TD="bgcolor: #DCE6F1"]
A​
[/TD]
[TD="bgcolor: #DCE6F1"]
B​
[/TD]
[TD="bgcolor: #DCE6F1"]
C​
[/TD]
[/TR]
[TR]
[TD="bgcolor: #DCE6F1"]
1​
[/TD]
[TD]
Header1​
[/TD]
[TD]
Header2​
[/TD]
[TD]
Header3​
[/TD]
[/TR]
[TR]
[TD="bgcolor: #DCE6F1"]
2​
[/TD]
[TD]
A​
[/TD]
[TD]
C​
[/TD]
[TD]
B​
[/TD]
[/TR]
[TR]
[TD="bgcolor: #DCE6F1"]
3​
[/TD]
[TD]
B​
[/TD]
[TD]
A​
[/TD]
[TD]
C​
[/TD]
[/TR]
[TR]
[TD="bgcolor: #DCE6F1"]
4​
[/TD]
[TD]
C​
[/TD]
[TD]
B​
[/TD]
[TD]
A​
[/TD]
[/TR]
</tbody>[/TABLE]


Macro
Code: 
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

[TABLE="class: grid"]
<tbody>[TR]
[TD="bgcolor: #DCE6F1"][/TD]
[TD="bgcolor: #DCE6F1"]
A​
[/TD]
[TD="bgcolor: #DCE6F1"]
B​
[/TD]
[TD="bgcolor: #DCE6F1"]
C​
[/TD]
[/TR]
[TR]
[TD="bgcolor: #DCE6F1"]
1​
[/TD]
[TD]
Header1​
[/TD]
[TD]
Header2​
[/TD]
[TD]
Header3​
[/TD]
[/TR]
[TR]
[TD="bgcolor: #DCE6F1"]
2​
[/TD]
[TD="bgcolor: #FF0000"]
A​
[/TD]
[TD="bgcolor: #0000FF"]
C​
[/TD]
[TD="bgcolor: #00FF00"]
B​
[/TD]
[/TR]
[TR]
[TD="bgcolor: #DCE6F1"]
3​
[/TD]
[TD="bgcolor: #00FF00"]
B​
[/TD]
[TD="bgcolor: #FF0000"]
A​
[/TD]
[TD="bgcolor: #0000FF"]
C​
[/TD]
[/TR]
[TR]
[TD="bgcolor: #DCE6F1"]
4​
[/TD]
[TD="bgcolor: #0000FF"]
C​
[/TD]
[TD="bgcolor: #00FF00"]
B​
[/TD]
[TD="bgcolor: #FF0000"]
A​
[/TD]
[/TR]
</tbody>[/TABLE]


M.
 
Upvote 0
Quick question - Can I assume that the number of names will change?
 
Upvote 0
Another option
Code: 
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
 
Upvote 0
so far I have this to collect the settings

Code: 
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)
Code: 
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
 
Upvote 0
I used a fixed range for it to compare
Code: 
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
 
Upvote 0
You must log in or register to reply here.

Similar threads

R
  • Question Question
multiple colours in shape fill or border fill change
Replies
0
Views
620
richie247
R
F
  • Question Question
Background colour value of cell in RGB-scale
Replies
3
Views
741
MickG
M
N
  • Question Question
To get cell Address value of Each Date displayed in a Range
2
Replies
18
Views
2K
DanteAmor
DanteAmor
D
  • Question Question
Change VBA code for Mac compatibility
Replies
7
Views
3K
ddewilt
D
V
  • Question Question
Vba code editing
Replies
5
Views
670
Vishaal
V

Forum statistics

Threads
1,223,894
Messages
6,175,254
Members
452,623
Latest member
Techenthusiast

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top