Require VBA to do CF with 2 colours in the alternate rows

[motilulla]

Hello,</SPAN></SPAN>

D7:Q23 for conditional format I am using the formula "=IF(D8="",0,IF(D8=0,1,0))" with one condition background red and font white I got 8000+ rows it works fine. </SPAN></SPAN>

Problem occurs when I tried to do 2 different colours for the alternate rows red & blue as shown in the second scenarios my workbook close with message not enough memory and when I force to close I see all CF is lost. But with one colour there is no problem </SPAN></SPAN>

Can it could be solved by VBA solution please</SPAN></SPAN>

Example data.... </SPAN></SPAN>

Book1
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S
1
2
3
4
5				n1	n2	n3	n4	n5	n6	n7	n8	n9	n10	n11	n12	n13	n14
6
7				1	0	0	0	1	0	1	0	1	1	0	0	1	0
8				2	1	1	0	2	1	0	0	2	0	1	1	0	0
9				3	0	0	0	3	0	1	0	3	1	0	0	1	0
10				4	0	0	1	4	0	2	0	0	2	1	0	0	0
11				0	1	0	2	0	0	3	0	0	3	2	1	0	0
12				1	2	1	3	1	1	0	0	1	0	0	0	0	1
13				2	0	0	4	0	0	0	1	0	0	1	0	1	0
14				0	1	1	5	0	1	0	0	0	1	0	0	2	0
15				0	0	0	6	1	2	1	0	1	2	0	1	3	1
16				0	1	1	0	0	0	0	0	2	0	0	2	4	0
17				1	0	2	1	0	1	1	1	3	0	0	0	5	1
18				0	0	3	0	1	0	2	0	0	0	1	0	6	0
19				0	0	0	0	0	1	0	0	0	1	2	1	0	0
20				1	0	0	1	1	0	0	0	0	2	0	0	1	1
21				0	0	0	0	2	0	1	1	0	3	1	0	2	2
22				0	0	0	1	3	0	0	2	0	4	0	0	3	0
23				1	0	1	0	0	1	0	0	0	5	0	0	0	1
Sheet2

Requir like as below

Book1
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S
1
2
3
4
5				n1	n2	n3	n4	n5	n6	n7	n8	n9	n10	n11	n12	n13	n14
6
7				1	0	0	0	1	0	1	0	1	1	0	0	1	0
8				2	1	1	0	2	1	0	0	2	0	1	1	0	0
9				3	0	0	0	3	0	1	0	3	1	0	0	1	0
10				4	0	0	1	4	0	2	0	0	2	1	0	0	0
11				0	1	0	2	0	0	3	0	0	3	2	1	0	0
12				1	2	1	3	1	1	0	0	1	0	0	0	0	1
13				2	0	0	4	0	0	0	1	0	0	1	0	1	0
14				0	1	1	5	0	1	0	0	0	1	0	0	2	0
15				0	0	0	6	1	2	1	0	1	2	0	1	3	1
16				0	1	1	0	0	0	0	0	2	0	0	2	4	0
17				1	0	2	1	0	1	1	1	3	0	0	0	5	1
18				0	0	3	0	1	0	2	0	0	0	1	0	6	0
19				0	0	0	0	0	1	0	0	0	1	2	1	0	0
20				1	0	0	1	1	0	0	0	0	2	0	0	1	1
21				0	0	0	0	2	0	1	1	0	3	1	0	2	2
22				0	0	0	1	3	0	0	2	0	4	0	0	3	0
23				1	0	1	0	0	1	0	0	0	5	0	0	0	1
Sheet3

Thank you all</SPAN></SPAN>

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

 

[onlyadrafter]

Hello,

Does this work as expected?

Have assumed you just want to colour the cells.

Sub DOUBLE_COLOUR()
    For MY_ROWS = 7 To Range("D" & Rows.Count).End(xlUp).Row - 1
        For MY_COLS = 4 To 17
            If Cells(MY_ROWS + 1, MY_COLS).Value <= Cells(MY_ROWS, MY_COLS).Value Then
                If Round(MY_ROWS / 2, 0) <> MY_ROWS / 2 Then
                    Cells(MY_ROWS, MY_COLS).Interior.Color = vbRed
                Else
                    Cells(MY_ROWS, MY_COLS).Interior.Color = vbBlue
                End If
                    Cells(MY_ROWS, MY_COLS).Font.Color = vbWhite
            End If
        Next MY_COLS
    Next MY_ROWS
End Sub

 

[motilulla]

Hello,

Does this work as expected?

Have assumed you just want to colour the cells.

Sub DOUBLE_COLOUR()
    For MY_ROWS = 7 To Range("D" & Rows.Count).End(xlUp).Row - 1
        For MY_COLS = 4 To 17
            If Cells(MY_ROWS + 1, MY_COLS).Value <= Cells(MY_ROWS, MY_COLS).Value Then
                If Round(MY_ROWS / 2, 0) <> MY_ROWS / 2 Then
                    Cells(MY_ROWS, MY_COLS).Interior.Color = vbRed
                Else
                    Cells(MY_ROWS, MY_COLS).Interior.Color = vbBlue
                End If
                    Cells(MY_ROWS, MY_COLS).Font.Color = vbWhite
            End If
        Next MY_COLS
    Next MY_ROWS
End Sub

onlyadrafter, your VBA code work very perfect! I did run with real data, after the colouring both rows in the red and blue colours, workbook saved the with no problem at all.</SPAN></SPAN>

Thank you very much for the help!</SPAN></SPAN>

Query solved!</SPAN></SPAN>

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