Need 3 different codes for colouring the different data

motilulla

Well-known Member
Joined
Feb 13, 2008
Messages
2,355
Office Version
  1. 2010
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
ABCDEFGHIJ
1
2
3
4
5n1n2n1n2n1n2
6H25H25H25
7HHHHHH
8H25H25H25
9925925925
1025H25H25H
11H9H9H9
12H25H25H25
1325H25H25H
14252525252525
1525H25H25H
16H25H25H25
17252525252525
18252525252525
19H25H25H25
20252525252525
21252525252525
22925925925
23252525252525
24H25H25H25
25252525252525
26H25H25H25
27259259259
28252525252525
29252525252525
30252525252525
31252525252525
3225H25H25H
33999999
3425H25H25H
35925925925
3625H25H25H
37H25H25H25
38H9H9H9
39H9H9H9
40259259259
Sheet 1


Thank you all
</SPAN></SPAN>

Excel 2000
</SPAN></SPAN>
Regards,
</SPAN></SPAN>
Moti
</SPAN></SPAN>
 
Last edited:

Excel Facts

How to fill five years of quarters?
Type 1Q-2023 in a cell. Grab the fill handle and drag down or right. After 4Q-2023, Excel will jump to 1Q-2024. Dash can be any character.
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>

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

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

Code:
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>
 
Last edited:
Upvote 0
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
ABCDEFG
1
2
3
4
5n1n2n3n4n5n6n7
6H25H25H25H
7HHHHHHH
8H25H25H25H
99259259259
1025H25H25H25
11H9H9H9H
12H25H25H25H
1325H25H25H25
1425252525252525
1525H25H25H25
16H25H25H25H
1725252525252525
1825252525252525
19H25H25H25H
2025252525252525
2125252525252525
229259259259
2325252525252525
24H25H25H25H
2525252525252525
26H25H25H25H
2725925925925
2825252525252525
2925252525252525
3025252525252525
3125252525252525
3225H25H25H25
339999999
3425H25H25H25
359259259259
3625H25H25H25
37H25H25H25H
38H9H9H9H
39H9H9H9H
4025925925925
Sheet 2


Code:
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>
 
Last edited:
Upvote 0

Forum statistics

Threads
1,213,562
Messages
6,114,326
Members
448,564
Latest member
ED38

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