VBA colour number of sequence with 3, 4 different colours

motilulla · Jan 25, 2019

Hello,

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

Here is an example...

Book1

A

B

C

D

E

1

2

3

4

5

n1

6

0

7

1

8

0

9

0

10

1

11

2

12

0

13

1

14

0

15

1

16

0

17

0

18

0

19

1

20

0

21

1

22

2

23

3

24

4

25

5

26

6

27

0

28

1

29

0

30

1

31

2

32

0

33

0

34

0

35

0

36

1

37

2

38

3

39

4

40

0

41

1

42

2

43

3

44

4

45

5

46

6

47

7

48

8

49

0

50

1

51

2

52

3

53

4

54

5

55

6

56

7

57

0

58

0

59

0

60

1

61

0

62

1

63

2

64

0

65

1

66

2

67

3

68

4

69

5

70

6

71

7

72

8

73

9

74

10

75

0

76

1

77

0

78

1

79

2

80

3

81

0

82

1

83

0

84

0

85

1

86

2

87

3

88

4

89

5

90

6

91

7

92

8

93

9

94

10

95

11

96

0

97

0

98

99

Sheet3

Thank you all

Excel 2000
Regards,
Moti

footoo · Jan 25, 2019

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

Rick Rothstein · Jan 25, 2019

footoo said:

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]

motilulla · Jan 26, 2019

footoo said:

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!

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 

Kind Regards,
Moti

motilulla · Jan 26, 2019

Rick Rothstein said:

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

Kind Regards,
Moti

footoo · Jan 26, 2019

motilulla said:
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

motilulla · Jan 27, 2019

footoo said:

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 

Have a great weekend

Kind Regards,
Moti

VBA colour number of sequence with 3, 4 different colours

motilulla

Well-known Member

Excel Facts

footoo

Well-known Member

Rick Rothstein

MrExcel MVP

motilulla

Well-known Member

motilulla

Well-known Member

footoo

Well-known Member

motilulla

Well-known Member

Similar threads

Forum statistics

Share this page

VBA colour number of sequence with 3, 4 different colours

motilulla

Well-known Member

Excel Facts

footoo

Well-known Member

Rick Rothstein

MrExcel MVP

motilulla

Well-known Member

motilulla

Well-known Member

footoo

Well-known Member

motilulla

Well-known Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock