# VBA colour number of sequence with 3, 4 different colours

#### motilulla

##### Well-known Member
Hello,</SPAN></SPAN>

Require VBA which can colour number of sequence with 3, 4 different colours
</SPAN></SPAN>
0 = no colour, all 1=single colour, rest 1+2, 1+2+3, 1+2+3+4, max sequence I got
</SPAN></SPAN>
1 to 14
</SPAN></SPAN>

Here is an example...
</SPAN></SPAN>

Book1
ABCDE
1
2
3
4
5n1
60
71
80
90
101
112
120
131
140
151
160
170
180
191
200
211
222
233
244
255
266
270
281
290
301
312
320
330
340
350
361
372
383
394
400
411
422
433
444
455
466
477
488
490
501
512
523
534
545
556
567
570
580
590
601
610
621
632
640
651
662
673
684
695
706
717
728
739
7410
750
761
770
781
792
803
810
821
830
840
851
862
873
884
895
906
917
928
939
9410
9511
960
970
98
99
Sheet3

Thank you all
</SPAN></SPAN>

Excel 2000
</SPAN></SPAN>
Regards,
</SPAN></SPAN>
Moti
</SPAN></SPAN>

Last edited:

### Excel Facts

What is =ROMAN(40) in Excel?
The Roman numeral for 40 is XL. Bill "MrExcel" Jelen's 40th book was called MrExcel XL.
If the column D data are constants :
Code:
``````Sub FillColor()
Dim a As Range, r As Range
Dim rng As Range: Set rng = Range([D7], Cells(Rows.Count, "D").End(xlUp))
rng.Replace What:="0", Replacement:="", LookAt:=xlWhole
rng.Interior.ColorIndex = xlNone
Set r = rng.SpecialCells(xlCellTypeConstants)
For Each a In r.Areas
Select Case a.Cells.Count
Case 1: a.Interior.ColorIndex = 3
Case 2: a.Interior.ColorIndex = 4
Case 3: a.Interior.ColorIndex = 6
Case 4: a.Interior.ColorIndex = 7
Case 5: a.Interior.ColorIndex = 8
Case 6: a.Interior.ColorIndex = 10
Case 7: a.Interior.ColorIndex = 14
Case 8: a.Interior.ColorIndex = 17
Case 9: a.Interior.ColorIndex = 18
Case 10: a.Interior.ColorIndex = 22
Case 11: a.Interior.ColorIndex = 23
Case 12: a.Interior.ColorIndex = 24
Case 13: a.Interior.ColorIndex = 40
Case 14: a.Interior.ColorIndex = 45
End Select
Next
rng.SpecialCells(xlCellTypeBlanks) = 0
End Sub``````

If the column D data are constants :
Code:
``````Sub FillColor()
Dim a As Range, r As Range
Dim rng As Range: Set rng = Range([D7], Cells(Rows.Count, "D").End(xlUp))
rng.Replace What:="0", Replacement:="", LookAt:=xlWhole
rng.Interior.ColorIndex = xlNone
Set r = rng.SpecialCells(xlCellTypeConstants)
For Each a In r.Areas
Select Case a.Cells.Count
Case 1: a.Interior.ColorIndex = 3
Case 2: a.Interior.ColorIndex = 4
Case 3: a.Interior.ColorIndex = 6
Case 4: a.Interior.ColorIndex = 7
Case 5: a.Interior.ColorIndex = 8
Case 6: a.Interior.ColorIndex = 10
Case 7: a.Interior.ColorIndex = 14
Case 8: a.Interior.ColorIndex = 17
Case 9: a.Interior.ColorIndex = 18
Case 10: a.Interior.ColorIndex = 22
Case 11: a.Interior.ColorIndex = 23
Case 12: a.Interior.ColorIndex = 24
Case 13: a.Interior.ColorIndex = 40
Case 14: a.Interior.ColorIndex = 45
End Select
Next
rng.SpecialCells(xlCellTypeBlanks) = 0
End Sub``````
We can compact your code somewhat...
Code:
``````[table="width: 500"]
[tr]
[td]Sub FillColor()
Dim A As Range
With Range([D6], Cells(Rows.Count, "D").End(xlUp))
.Replace What:="0", Replacement:="", LookAt:=xlWhole
.Interior.ColorIndex = xlNone
For Each A In .SpecialCells(xlCellTypeConstants).Areas
A.Interior.ColorIndex = Split("3 4 6 7 8 10 14 17 18 22 23 24 40 45")(A.Count - 1)
Next
.SpecialCells(xlCellTypeBlanks) = 0
End With
End Sub[/td]
[/tr]
[/table]``````

If the column D data are constants :
Code:
``````Sub FillColor()
Dim a As Range, r As Range
Dim rng As Range: Set rng = Range([D7], Cells(Rows.Count, "D").End(xlUp))
rng.Replace What:="0", Replacement:="", LookAt:=xlWhole
rng.Interior.ColorIndex = xlNone
Set r = rng.SpecialCells(xlCellTypeConstants)
For Each a In r.Areas
Select Case a.Cells.Count
Case 1: a.Interior.ColorIndex = 3
Case 2: a.Interior.ColorIndex = 4
Case 3: a.Interior.ColorIndex = 6
Case 4: a.Interior.ColorIndex = 7
Case 5: a.Interior.ColorIndex = 8
Case 6: a.Interior.ColorIndex = 10
Case 7: a.Interior.ColorIndex = 14
Case 8: a.Interior.ColorIndex = 17
Case 9: a.Interior.ColorIndex = 18
Case 10: a.Interior.ColorIndex = 22
Case 11: a.Interior.ColorIndex = 23
Case 12: a.Interior.ColorIndex = 24
Case 13: a.Interior.ColorIndex = 40
Case 14: a.Interior.ColorIndex = 45
End Select
Next
rng.SpecialCells(xlCellTypeBlanks) = 0
End Sub``````
footoo, VBA worked Perfect! Thank you very much for the help!</SPAN></SPAN>

I need an addition for example "Case 6: a.Interior.ColorIndex = 10" is filled with dark green colour I need in this case if can be added font white for better visualization and may be in other cases if I require </SPAN></SPAN>

Kind Regards,</SPAN></SPAN>
Moti </SPAN></SPAN>

We can compact your code somewhat...
Code:
``````[TABLE="width: 500"]
<TBODY>[TR]
[TD]Sub FillColor()
Dim A As Range
With Range([D6], Cells(Rows.Count, "D").End(xlUp))
.Replace What:="0", Replacement:="", LookAt:=xlWhole
.Interior.ColorIndex = xlNone
For Each A In .SpecialCells(xlCellTypeConstants).Areas
A.Interior.ColorIndex = Split("3 4 6 7 8 10 14 17 18 22 23 24 40 45")(A.Count - 1)
Next
.SpecialCells(xlCellTypeBlanks) = 0
End With
End Sub
[/TD]
[/TR]
</TBODY>[/TABLE]``````
Rick Rothstein, thank you for compacting the code</SPAN></SPAN>

Kind Regards,</SPAN></SPAN>
Moti

I need an addition for example "Case 6: a.Interior.ColorIndex = 10" is filled with dark green colour I need in this case if can be added font white for better visualization and may be in other cases if I require
Moti

Code:
``````Sub FillColor()
Dim a As Range
With Range([D6], Cells(Rows.Count, "D").End(xlUp))
.Replace What:="0", Replacement:="", LookAt:=xlWhole
.Interior.ColorIndex = xlNone
.Font.ColorIndex = xlAutomatic
For Each a In .SpecialCells(xlCellTypeConstants).Areas
a.Interior.ColorIndex = Split("3 4 6 7 8 10 14 17 18 22 23 24 40 45")(a.Count - 1)
If a.Count = 1 Or a.Count = 6 Or a.Count = 11 Then a.Font.ColorIndex = 2
Next
.SpecialCells(xlCellTypeBlanks) = 0
End With
End Sub``````

Or :
Code:
``````Sub FillColor()
Dim a As Range, r As Range
Dim rng As Range: Set rng = Range([D7], Cells(Rows.Count, "D").End(xlUp))
rng.Replace What:="0", Replacement:="", LookAt:=xlWhole
rng.Interior.ColorIndex = xlNone
rng.Font.ColorIndex = xlAutomatic
Set r = rng.SpecialCells(xlCellTypeConstants)
For Each a In r.Areas
Select Case a.Cells.Count
Case 1
a.Interior.ColorIndex = 3
a.Font.ColorIndex = 2
Case 2: a.Interior.ColorIndex = 4
Case 3: a.Interior.ColorIndex = 6
Case 4: a.Interior.ColorIndex = 7
Case 5: a.Interior.ColorIndex = 8
Case 6
a.Interior.ColorIndex = 10
a.Font.ColorIndex = 2
Case 7: a.Interior.ColorIndex = 14
Case 8: a.Interior.ColorIndex = 17
Case 9: a.Interior.ColorIndex = 18
Case 10: a.Interior.ColorIndex = 22
Case 11
a.Interior.ColorIndex = 23
a.Font.ColorIndex = 2
Case 12: a.Interior.ColorIndex = 24
Case 13: a.Interior.ColorIndex = 40
Case 14: a.Interior.ColorIndex = 45
End Select
Next
rng.SpecialCells(xlCellTypeBlanks) = 0
End Sub``````

Alternatively, it might be better to avoid dark colours and have all fonts in black.
The following link has a colour chart with colorindex numbers :
http://dmcritchie.mvps.org/excel/colors.htm

Code:
``````Sub FillColor()
Dim a As Range
With Range([D6], Cells(Rows.Count, "D").End(xlUp))
.Replace What:="0", Replacement:="", LookAt:=xlWhole
.Interior.ColorIndex = xlNone
.Font.ColorIndex = xlAutomatic
For Each a In .SpecialCells(xlCellTypeConstants).Areas
a.Interior.ColorIndex = Split("3 4 6 7 8 10 14 17 18 22 23 24 40 45")(a.Count - 1)
If a.Count = 1 Or a.Count = 6 Or a.Count = 11 Then a.Font.ColorIndex = 2
Next
.SpecialCells(xlCellTypeBlanks) = 0
End With
End Sub``````

Or :
Code:
``````Sub FillColor()
Dim a As Range, r As Range
Dim rng As Range: Set rng = Range([D7], Cells(Rows.Count, "D").End(xlUp))
rng.Replace What:="0", Replacement:="", LookAt:=xlWhole
rng.Interior.ColorIndex = xlNone
rng.Font.ColorIndex = xlAutomatic
Set r = rng.SpecialCells(xlCellTypeConstants)
For Each a In r.Areas
Select Case a.Cells.Count
Case 1
a.Interior.ColorIndex = 3
a.Font.ColorIndex = 2
Case 2: a.Interior.ColorIndex = 4
Case 3: a.Interior.ColorIndex = 6
Case 4: a.Interior.ColorIndex = 7
Case 5: a.Interior.ColorIndex = 8
Case 6
a.Interior.ColorIndex = 10
a.Font.ColorIndex = 2
Case 7: a.Interior.ColorIndex = 14
Case 8: a.Interior.ColorIndex = 17
Case 9: a.Interior.ColorIndex = 18
Case 10: a.Interior.ColorIndex = 22
Case 11
a.Interior.ColorIndex = 23
a.Font.ColorIndex = 2
Case 12: a.Interior.ColorIndex = 24
Case 13: a.Interior.ColorIndex = 40
Case 14: a.Interior.ColorIndex = 45
End Select
Next
rng.SpecialCells(xlCellTypeBlanks) = 0
End Sub``````

Alternatively, it might be better to avoid dark colours and have all fonts in black.
The following link has a colour chart with colorindex numbers :
http://dmcritchie.mvps.org/excel/colors.htm
footoo, very much appreciated for fulfilling my second request. And thank you for the link has a colour chart with colorindex numbers: it is nice of you </SPAN></SPAN>

Have a great weekend
</SPAN></SPAN>

Kind Regards,
</SPAN></SPAN>
Moti
</SPAN></SPAN>

Replies
1
Views
124
Replies
0
Views
293
Replies
7
Views
276
Replies
1
Views
111
Replies
10
Views
262

1,196,485
Messages
6,015,472
Members
441,898
Latest member
kofafa

### 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?

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