Need 3 different codes for colouring the different data

[motilulla]

Hello,</SPAN></SPAN>

I have 3 different scenarios for that I need 3 separate different codes to colour them as shown below</SPAN></SPAN>

Scenario-1 Columns C & D colour all case occurred more then 1 time continuously like H=2 times & 3 times, 9=3 times and 25=2 & more times</SPAN></SPAN>

Scenario-2 Columns F & G colour cells only with values 25 & H</SPAN></SPAN>

Scenario-3 Columns I & J colour cells only with values 9 & 25</SPAN></SPAN>

Book1
	A	B	C	D	E	F	G	H	I	J
1
2
3
4
5			n1	n2		n1	n2		n1	n2
6			H	25		H	25		H	25
7			H	H		H	H		H	H
8			H	25		H	25		H	25
9			9	25		9	25		9	25
10			25	H		25	H		25	H
11			H	9		H	9		H	9
12			H	25		H	25		H	25
13			25	H		25	H		25	H
14			25	25		25	25		25	25
15			25	H		25	H		25	H
16			H	25		H	25		H	25
17			25	25		25	25		25	25
18			25	25		25	25		25	25
19			H	25		H	25		H	25
20			25	25		25	25		25	25
21			25	25		25	25		25	25
22			9	25		9	25		9	25
23			25	25		25	25		25	25
24			H	25		H	25		H	25
25			25	25		25	25		25	25
26			H	25		H	25		H	25
27			25	9		25	9		25	9
28			25	25		25	25		25	25
29			25	25		25	25		25	25
30			25	25		25	25		25	25
31			25	25		25	25		25	25
32			25	H		25	H		25	H
33			9	9		9	9		9	9
34			25	H		25	H		25	H
35			9	25		9	25		9	25
36			25	H		25	H		25	H
37			H	25		H	25		H	25
38			H	9		H	9		H	9
39			H	9		H	9		H	9
40			25	9		25	9		25	9
Sheet 1

Thank you all</SPAN></SPAN>

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

 

[motilulla]

bump</SPAN></SPAN>

 

[motilulla]

Hello,</SPAN></SPAN>

Searching in "MrExcel" forms find few codes and combining them I got desire result for all 3 scenarios. </SPAN></SPAN>

But now I am finding the problems, need help is it possible to make the code shorter so it can work with 7 columns at once. (For now code works with only for 2 columns for that I have repeated part of code line 2 times *for 7 columns I need to repeat 7 times, which I don't want*) Please help

Note: I need cells formatting for column A:G, for each scenarios</SPAN></SPAN>

Sub FormattingCells_Scenario1()

    Dim numrow As Long
    Dim r As Long
    
    
    Application.ScreenUpdating = False
    numrow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
    For r = 6 To numrow
    c = Cells(r, "A").Value
    d = Cells(r - 1, "A").Value
    If c = 9 And d = 9 Then
         
         Range(Cells(r - 1, "A"), Cells(r, "A")).Interior.Color = vbBlue
End If
   Next
'-------------------------------------------------------------
    For r = 6 To numrow
    c = Cells(r, "B").Value
    d = Cells(r - 1, "B").Value
    If c = 9 And d = 9 Then
         
         Range(Cells(r - 1, "B"), Cells(r, "B")).Interior.Color = vbCyan
End If
   Next
'-------------------------------------------------------------
   
   
   Application.ScreenUpdating = True
End Sub

Sub FormattingCells_Scenario2()

    Dim numrow As Long
    Dim r As Long
    
    
    Application.ScreenUpdating = False
    numrow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
    For r = 6 To numrow
    c = Cells(r, "A").Value
    d = Cells(r - 1, "A").Value
    If c = "H" And d = 25 Then
         
         Range(Cells(r - 1, "A"), Cells(r, "A")).Interior.Color = vbYellow
End If
   Next
'-------------------------------------------------------------
    For r = 6 To numrow
    c = Cells(r, "B").Value
    d = Cells(r - 1, "B").Value
    If c = "H" And d = 25 Then
         
         Range(Cells(r - 1, "B"), Cells(r, "B")).Interior.Color = vbYellow
End If
   Next
'-------------------------------------------------------------
   
   
   Application.ScreenUpdating = True
End Sub

Sub FormattingCells_Scenario3()

    Dim numrow As Long
    Dim r As Long
    
    
    Application.ScreenUpdating = False
    numrow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
    For r = 6 To numrow
    c = Cells(r, "A").Value
    d = Cells(r - 1, "A").Value
    If c = 25 And d = 9 Then
         
         Range(Cells(r - 1, "A"), Cells(r, "A")).Interior.Color = vbGreen
End If
   Next
'-------------------------------------------------------------
    For r = 6 To numrow
    c = Cells(r, "B").Value
    d = Cells(r - 1, "B").Value
    If c = 25 And d = 9 Then
         
         Range(Cells(r - 1, "B"), Cells(r, "B")).Interior.Color = vbGreen
End If
   Next
'-------------------------------------------------------------
   
   
   Application.ScreenUpdating = True
End Sub

Thank you all</SPAN></SPAN>

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

 

[motilulla]

Hello,</SPAN></SPAN>

I really do not believe my self but got it work for code for scenario2 for 7 columns and rest scenario1 & Scenario3 need only adjustment in the line " If c = "H" And d = 25 Then" as required here below is the example and code. </SPAN></SPAN>

Book1
	A	B	C	D	E	F	G
1
2
3
4
5	n1	n2	n3	n4	n5	n6	n7
6	H	25	H	25	H	25	H
7	H	H	H	H	H	H	H
8	H	25	H	25	H	25	H
9	9	25	9	25	9	25	9
10	25	H	25	H	25	H	25
11	H	9	H	9	H	9	H
12	H	25	H	25	H	25	H
13	25	H	25	H	25	H	25
14	25	25	25	25	25	25	25
15	25	H	25	H	25	H	25
16	H	25	H	25	H	25	H
17	25	25	25	25	25	25	25
18	25	25	25	25	25	25	25
19	H	25	H	25	H	25	H
20	25	25	25	25	25	25	25
21	25	25	25	25	25	25	25
22	9	25	9	25	9	25	9
23	25	25	25	25	25	25	25
24	H	25	H	25	H	25	H
25	25	25	25	25	25	25	25
26	H	25	H	25	H	25	H
27	25	9	25	9	25	9	25
28	25	25	25	25	25	25	25
29	25	25	25	25	25	25	25
30	25	25	25	25	25	25	25
31	25	25	25	25	25	25	25
32	25	H	25	H	25	H	25
33	9	9	9	9	9	9	9
34	25	H	25	H	25	H	25
35	9	25	9	25	9	25	9
36	25	H	25	H	25	H	25
37	H	25	H	25	H	25	H
38	H	9	H	9	H	9	H
39	H	9	H	9	H	9	H
40	25	9	25	9	25	9	25
Sheet 2

Sub FormattingCells_Scenario2()

    Dim numrow As Long
    Dim r As Long
    Dim column As Long 'new
    
    Application.ScreenUpdating = False
    numrow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
    
    For column = 1 To 7 'new
    For r = 6 To numrow
    c = Cells(r, column).Value
    d = Cells(r - 1, column).Value
    If c = "H" And d = 25 Then
         
         Range(Cells(r - 1, column), Cells(r, column)).Interior.Color = vbYellow
    End If
       Next
   
   Next
Application.ScreenUpdating = True
End Sub

Thank you all</SPAN></SPAN>

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