hightlight row(s) based on value

Trevor3007

Trevor3007

Well-known Member
Joined
Jan 26, 2017
Messages
675
Office Version
  1. 365
Platform
  1. Windows
Hi,

Does any have the 'VB knowhow' to highlight a row(s) that contain a certain value?

The range is c2:c200 & if it contains any of the following keywords:-

base test completed OK - light green\bold

base test completed failure - Light red\bold

base test on test - light yellow\bold

thank you 'kind person' & i look forward to your reply.

KR
Trevor 3007
 
Last edited:
Sort by date Sort by votes
Thank you Rick,

mumps got in 1st & apart from
the only issue I could find is that if a cell that previously had triggered the 'colour' change, if I remove\edit\remove the value , the applicable row remains 'coloured filled' where I thought it would be 'blanked filled'

all seems good?

Thank you for ALL your help & hope you have a great Christmas .

Kindest regards
Trevor3007
 
Upvote 0

Excel Facts

Show numbers in thousands?
Use a custom number format of #,##0,K. Each comma after the final 0 will divide the displayed number by another thousand
To take care of the blanks, try:
Code: 
Sub ColorRows()
    Application.ScreenUpdating = False
    Dim rng As Range
    For Each rng In Range("C2:C200")
        Select Case rng.Value
            Case "Build Completed"
                With Range("A" & rng.Row).Resize(1, 24)
                    .Interior.ColorIndex = 4
                    .Font.Bold = True
                End With
            Case "Swapped-Out"
                With Range("A" & rng.Row).Resize(1, 24)
                    .Interior.ColorIndex = 3
                    .Font.Bold = True
                End With
            Case "Build Started"
                With Range("A" & rng.Row).Resize(1, 24)
                    .Interior.ColorIndex = 6
                    .Font.Bold = True
                End With
            Case "Device Not Received"
                With Range("A" & rng.Row).Resize(1, 24)
                    .Interior.ColorIndex = 28
                    .Font.Bold = True
                End With
            Case "Emailed Requested For SCCM Check"
                With Range("A" & rng.Row).Resize(1, 24)
                    .Interior.ColorIndex = 38
                    .Font.Bold = True
                End With
            Case "Desktop UAD - On Hold ATM"
                With Range("A" & rng.Row).Resize(1, 24)
                    .Interior.ColorIndex = 44
                    .Font.Bold = True
                End With
            Case "Device With Build Engineer"
                With Range("A" & rng.Row).Resize(1, 24)
                    .Interior.ColorIndex = xlNone
                    .Font.Bold = False
                End With
            Case ""
                With Range("A" & rng.Row).Resize(1, 24)
                    .Interior.ColorIndex = xlNone
                    .Font.Bold = False
                End With
        End Select
    Next rng
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
Here is my code modified (and a couple of bugs fixed) that will do what you are requesting for your new status text values and colors. I also separated the code that handles each individual status value with empty lines... you should be able to use any one of them as a guide should you need to add more status checks in the future.
Code: 
[table="width: 500"]
[tr]
	[td]Sub ColorRows()
  Application.ScreenUpdating = False
  On Error Resume Next
  With Range("C3:C300")
    .Offset(, -2).Resize(, 26).Interior.ColorIndex = xlColorIndexNone
    .Offset(, -2).Resize(, 26).Font.Bold = False
  
    .Replace "Build Completed", "=Build Completed", xlWhole, , False, , False, False
    With Intersect(.SpecialCells(xlFormulas).EntireRow, Columns("A:X"))
      .Interior.ColorIndex = 4
      .Font.Bold = True
    End With
    Columns("C").Replace "=", "", xlPart
    
    .Replace "Build Started", "=Build Started", xlWhole, , False, , False, False
    With Intersect(.SpecialCells(xlFormulas).EntireRow, Columns("A:X"))
      .Interior.ColorIndex = 6
      .Font.Bold = True
    End With
    Columns("C").Replace "=", "", xlPart
    
    .Replace "Device Not Received", "=Device Not Received", xlWhole, , False, , False, False
    With Intersect(.SpecialCells(xlFormulas).EntireRow, Columns("A:X"))
      .Interior.ColorIndex = 33
      .Font.Bold = True
    End With
    Columns("C").Replace "=", "", xlPart
    
    .Replace "Device With Build Engineer", "=Device With Build Engineer", xlWhole, , False, , False, False
    With Intersect(.SpecialCells(xlFormulas).EntireRow, Columns("A:X"))
      .Interior.ColorIndex = xlColorIndexNone
      .Font.Bold = True
    End With
    Columns("C").Replace "=", "", xlPart
    
    .Replace "Emailed Requested For SCCM Check", "=Emailed Requested For SCCM Check", xlWhole, , False, , False, False
    With Intersect(.SpecialCells(xlFormulas).EntireRow, Columns("A:X"))
      .Interior.ColorIndex = 39
      .Font.Bold = True
    End With
    Columns("C").Replace "=", "", xlPart
    
    .Replace "Swapped-Out", "=Swapped-Out", xlWhole, , False, , False, False
    With Intersect(.SpecialCells(xlFormulas).EntireRow, Columns("A:X"))
      .Interior.ColorIndex = 38
      .Font.Bold = True
    End With
    Columns("C").Replace "=", "", xlPart
    
    .Replace "Desktop UAD - On Hold ATM", "=Desktop UAD - On Hold ATM", xlWhole, , False, , False, False
    With Intersect(.SpecialCells(xlFormulas).EntireRow, Columns("A:X"))
      .Interior.ColorIndex = 45
      .Font.Bold = True
    End With
    Columns("C").Replace "=", "", xlPart
    
  End With
  On Error GoTo 0
  Application.ScreenUpdating = True
End Sub[/td]
[/tr]
[/table]
 
Upvote 0
Rick Rothstein said:
Here is my code modified (and a couple of bugs fixed) that will do what you are requesting for your new status text values and colors. I also separated the code that handles each individual status value with empty lines... you should be able to use any one of them as a guide should you need to add more status checks in the future.
Code: 
[table="width: 500"]
[tr]
	[td]Sub ColorRows()
  Application.ScreenUpdating = False
  On Error Resume Next
  With Range("C3:C300")
    .Offset(, -2).Resize(, 26).Interior.ColorIndex = xlColorIndexNone
    .Offset(, -2).Resize(, 26).Font.Bold = False
  
    .Replace "Build Completed", "=Build Completed", xlWhole, , False, , False, False
    With Intersect(.SpecialCells(xlFormulas).EntireRow, Columns("A:X"))
      .Interior.ColorIndex = 4
      .Font.Bold = True
    End With
    Columns("C").Replace "=", "", xlPart
    
    .Replace "Build Started", "=Build Started", xlWhole, , False, , False, False
    With Intersect(.SpecialCells(xlFormulas).EntireRow, Columns("A:X"))
      .Interior.ColorIndex = 6
      .Font.Bold = True
    End With
    Columns("C").Replace "=", "", xlPart
    
    .Replace "Device Not Received", "=Device Not Received", xlWhole, , False, , False, False
    With Intersect(.SpecialCells(xlFormulas).EntireRow, Columns("A:X"))
      .Interior.ColorIndex = 33
      .Font.Bold = True
    End With
    Columns("C").Replace "=", "", xlPart
    
    .Replace "Device With Build Engineer", "=Device With Build Engineer", xlWhole, , False, , False, False
    With Intersect(.SpecialCells(xlFormulas).EntireRow, Columns("A:X"))
      .Interior.ColorIndex = xlColorIndexNone
      .Font.Bold = True
    End With
    Columns("C").Replace "=", "", xlPart
    
    .Replace "Emailed Requested For SCCM Check", "=Emailed Requested For SCCM Check", xlWhole, , False, , False, False
    With Intersect(.SpecialCells(xlFormulas).EntireRow, Columns("A:X"))
      .Interior.ColorIndex = 39
      .Font.Bold = True
    End With
    Columns("C").Replace "=", "", xlPart
    
    .Replace "Swapped-Out", "=Swapped-Out", xlWhole, , False, , False, False
    With Intersect(.SpecialCells(xlFormulas).EntireRow, Columns("A:X"))
      .Interior.ColorIndex = 38
      .Font.Bold = True
    End With
    Columns("C").Replace "=", "", xlPart
    
    .Replace "Desktop UAD - On Hold ATM", "=Desktop UAD - On Hold ATM", xlWhole, , False, , False, False
    With Intersect(.SpecialCells(xlFormulas).EntireRow, Columns("A:X"))
      .Interior.ColorIndex = 45
      .Font.Bold = True
    End With
    Columns("C").Replace "=", "", xlPart
    
  End With
  On Error GoTo 0
  Application.ScreenUpdating = True
End Sub[/td]
[/tr]
[/table]
Click to expand...
Okay, I reduced the size of my macro by using an array to hold each individual status text followed by a pipe (|) symbol in a quoted comma delimited list... that way I can iterate the array thereby reducing the overall size of my macro. Here is that revised code...
Code: 
[table="width: 500"]
[tr]
	[td]Sub ColorRows()
  Dim X As Long, Status As Variant, Parts() As String
  Status = Array("Build Completed|4", "Build Started|6", "Device Not Received|33", "Device With Build Engineer|-4142", "Emailed Requested For SCCM Check|39", "Swapped-Out|38", "Desktop UAD - On Hold ATM|45")
  Application.ScreenUpdating = False
  On Error Resume Next
  With Range("C3:C300")
    .Offset(, -2).Resize(, 26).Interior.ColorIndex = xlColorIndexNone
    .Offset(, -2).Resize(, 26).Font.Bold = False
  
    For X = LBound(Status) To UBound(Status)
      Parts = Split(Status(X), "|")
      .Replace Parts(0), "=" & Parts(0), xlWhole, , False, , False, False
      With Intersect(.SpecialCells(xlFormulas).EntireRow, Columns("A:X"))
        .Interior.ColorIndex = Parts(1)
        .Font.Bold = True
      End With
      Columns("C").Replace "=", "", xlPart
    Next
    
  End With
  On Error GoTo 0
  Application.ScreenUpdating = True
End Sub[/td]
[/tr]
[/table]
 
Upvote 0
mumps said:
To take care of the blanks, try:
Code: 
Sub ColorRows()
    Application.ScreenUpdating = False
    Dim rng As Range
    For Each rng In Range("C2:C200")
        Select Case rng.Value
            Case "Build Completed"
                With Range("A" & rng.Row).Resize(1, 24)
                    .Interior.ColorIndex = 4
                    .Font.Bold = True
                End With
            Case "Swapped-Out"
                With Range("A" & rng.Row).Resize(1, 24)
                    .Interior.ColorIndex = 3
                    .Font.Bold = True
                End With
            Case "Build Started"
                With Range("A" & rng.Row).Resize(1, 24)
                    .Interior.ColorIndex = 6
                    .Font.Bold = True
                End With
            Case "Device Not Received"
                With Range("A" & rng.Row).Resize(1, 24)
                    .Interior.ColorIndex = 28
                    .Font.Bold = True
                End With
            Case "Emailed Requested For SCCM Check"
                With Range("A" & rng.Row).Resize(1, 24)
                    .Interior.ColorIndex = 38
                    .Font.Bold = True
                End With
            Case "Desktop UAD - On Hold ATM"
                With Range("A" & rng.Row).Resize(1, 24)
                    .Interior.ColorIndex = 44
                    .Font.Bold = True
                End With
            Case "Device With Build Engineer"
                With Range("A" & rng.Row).Resize(1, 24)
                    .Interior.ColorIndex = xlNone
                    .Font.Bold = False
                End With
            Case ""
                With Range("A" & rng.Row).Resize(1, 24)
                    .Interior.ColorIndex = xlNone
                    .Font.Bold = False
                End With
        End Select
    Next rng
    Application.ScreenUpdating = True
End Sub
Click to expand...


WOW mumps,

Thats it................fan tas tic !!

i did a wee tweak here & there ( shortened the length from 24 to 22.
Code: 
Private Sub Worksheet_Change(ByVal Target As Range)


Application.ScreenUpdating = False
    Dim rng As Range
    For Each rng In Range("h4:h200")
        Select Case rng.Value
            Case "Build Completed"
                With Range("A" & rng.Row).Resize(1, 22)
                    .Interior.ColorIndex = 4
                    .Font.Bold = True
                End With
            Case "Swapped-Out"
                With Range("A" & rng.Row).Resize(1, 22)
                    .Interior.ColorIndex = 22
                    .Font.Bold = True
                End With
            Case "Build Started"
                With Range("A" & rng.Row).Resize(1, 22)
                    .Interior.ColorIndex = 6
                    .Font.Bold = True
                End With
            Case "Device Not Received"
                With Range("A" & rng.Row).Resize(1, 22)
                    .Interior.ColorIndex = 28
                    .Font.Bold = True
                End With
            Case "Emailed Requested For SCCM Check"
                With Range("A" & rng.Row).Resize(1, 22)
                    .Interior.ColorIndex = 38
                    .Font.Bold = True
                End With
            Case "Desktop UAD - On Hold ATM"
                With Range("A" & rng.Row).Resize(1, 22)
                    .Interior.ColorIndex = 44
                    .Font.Bold = True
                End With
            Case "Device With Build Engineer"
                With Range("A" & rng.Row).Resize(1, 22)
                    .Interior.ColorIndex = 46
                    .Font.Bold = False
                End With
            Case ""
                With Range("A" & rng.Row).Resize(1, 22)
                    .Interior.ColorIndex = xlNone
                    .Font.Bold = False
                End With
        End Select
    Next rng
    Application.ScreenUpdating = True
    
    
    
    If Target.Cells.Count > 1 Or Target.HasFormula Then Exit Sub






    On Error Resume Next


    If Not Intersect(Target, Range("a4:a200")) Is Nothing Then


        Application.EnableEvents = False


        Target = UCase(Target)


        Application.EnableEvents = True


    End If
      


    On Error GoTo 0




If Target.Cells.Count > 1 Or Target.HasFormula Then Exit Sub






    On Error Resume Next


    If Not Intersect(Target, Range("c4:c200")) Is Nothing Then


        Application.EnableEvents = False


        Target = StrConv(Target, vbProperCase)


        Application.EnableEvents = True


    End If


    On Error GoTo 0
    
    
    
    
     If Target.Cells.Count > 1 Or Target.HasFormula Then Exit Sub






    On Error Resume Next


    If Not Intersect(Target, Range("d4:d200")) Is Nothing Then


        Application.EnableEvents = False


        Target = LCase(Target)


        Application.EnableEvents = True


    End If
      


    On Error GoTo 0
    
    
   If Target.Cells.Count > 1 Or Target.HasFormula Then Exit Sub






    On Error Resume Next


    If Not Intersect(Target, Range("g4:g200")) Is Nothing Then


        Application.EnableEvents = False


        Target = UCase(Target)


        Application.EnableEvents = True


    End If
      


    On Error GoTo 0
   
   
   
    If Target.Cells.Count > 1 Or Target.HasFormula Then Exit Sub






    On Error Resume Next


    If Not Intersect(Target, Range("F4:F200")) Is Nothing Then


        Application.EnableEvents = False


        Target = LCase(Target)


        Application.EnableEvents = True


    End If
      


    On Error GoTo 0
    
    
    
End Sub


The above is what i am now using... including tweaks. There is also additional code which is to change from\to UPPER\lower\Proper Case.

Many thanks for all the help & hope you have a great Christmas....ho,ho,hoooo:beerchug::beerchug::beerchug:
 
Last edited:
Upvote 0
Rick Rothstein said:
Okay, I reduced the size of my macro by using an array to hold each individual status text followed by a pipe (|) symbol in a quoted comma delimited list... that way I can iterate the array thereby reducing the overall size of my macro. Here is that revised code...
Code: 
[TABLE="width: 500"]
<tbody>[TR]
[TD]Sub ColorRows()
  Dim X As Long, Status As Variant, Parts() As String
  Status = Array("Build Completed|4", "Build Started|6", "Device Not Received|33", "Device With Build Engineer|-4142", "Emailed Requested For SCCM Check|39", "Swapped-Out|38", "Desktop UAD - On Hold ATM|45")
  Application.ScreenUpdating = False
  On Error Resume Next
  With Range("C3:C300")
    .Offset(, -2).Resize(, 26).Interior.ColorIndex = xlColorIndexNone
    .Offset(, -2).Resize(, 26).Font.Bold = False
  
    For X = LBound(Status) To UBound(Status)
      Parts = Split(Status(X), "|")
      .Replace Parts(0), "=" & Parts(0), xlWhole, , False, , False, False
      With Intersect(.SpecialCells(xlFormulas).EntireRow, Columns("A:X"))
        .Interior.ColorIndex = Parts(1)
        .Font.Bold = True
      End With
      Columns("C").Replace "=", "", xlPart
    Next
    
  End With
  On Error GoTo 0
  Application.ScreenUpdating = True
End Sub[/TD]
[/TR]
</tbody>[/TABLE]
Click to expand...


hi Rick,

I was in process of replying when i just received your last post.

Yeah i tried your code, but when it ran, it 'blanked' everything... i don't know why, and hence why i used mumps.

thank you very much and hope you have a great Christmas.
MTA
Trevor3007
 
Upvote 0
Trevor3007 said:
hi Rick,

Yeah i tried your code, but when it ran, it 'blanked' everything... i don't know why, and hence why i used mumps.
Click to expand...
The only way I can think of that my code would do that is if the cells in Column C contained formulas rather than constants (which I took your answer in Message #7 to mean it didn't). Other than that, I do not think my code can "blank" out any other type of cells. Any chance you can post your workbook to DropBox so that I (we) can take a look at your actual data? By the way, just so you know, I tested code I posted in Message #24 before posting it and it worked perfectly in my XL2010 Excel program.
 
Last edited:
Upvote 0
Rick Rothstein said:
The only way I can think of that my code would do that is if the cells in Column C contained formulas rather than constants (which I took your answer in Message #7 to mean it didn't). Other than that, I do not think my code can "blank" out any other type of cells. Any chance you can post your workbook to DropBox so that I (we) can take a look at your actual data? By the way, just so you know, I tested code I posted in Message #24 before posting it and it worked perfectly in my XL2010 Excel program.
Click to expand...


hi Rick,

try this via
https://1drv.ms/x/s!AvGGXsEtXRpdhLQHyELCe4_vqrpnMA


Kind regards
Trevor3007
 
Upvote 0
You must log in or register to reply here.

Similar threads

E
  • Question Question
Specific VBA Function
Replies
0
Views
261
EAlexWolfe
E
J
  • Question Question
Copying Rows Based on Column Value
Replies
1
Views
181
jolivanes
jolivanes
D
  • Solved
Copy row based on cell value and paste as text in another worksheet
Replies
2
Views
922
DH937
D
P
  • Question Question
Moving rows to different sheets based on drop down.
2
Replies
12
Views
1K
purevega
P
T
  • Solved
Hiding A row based on second work sheet based on Yes / No dropdown on first work sheet help....
Replies
5
Views
614
James006
James006

Forum statistics

Threads
1,224,823
Messages
6,181,181
Members
453,022
Latest member
Mohamed Magdi Tawfiq Emam

Share this page

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