Highlighting out of range values and adding corresponding text in VBA

B

bmt216a

New Member
Joined
Dec 15, 2022
Messages
11
Office Version
  1. 2019
Platform
  1. Windows
Hello everyone, I am trying to create something like the attached image below. There are 4 conditions.

The first, I want to automatically highlight any value in column D that is greater than 1.5 and in turn highlight the corresponding rows in columns B and C. I've already managed do half of it, but I need to input text to the right of it saying "Skew too high, don't use" and the rows to be highlighted as well.

Next, I need to set upper and lower limit values in column C and add corresponding text to it on the right side if the upper and lower limit conditions aren't met. In this example, any value greater than 574 (and the corresponding rows in columns B and C) will need to be highlighted in yellow and the text: "TD too high, scrap" to appear to the right of it. Any value lower than 554 (and the corresponding rows in columns B and C) will also need to be highlighted in yellow and the text should say: "TD too low, scrap" to the right of it.

Lastly, any value that does not have a pair, in this case #111 in column B will also need to be highlighted in yellow and the text: "Unmatched" to be written to the right of it.

I will attach my code and show you what I have so far. This code includes a few different operations in it that I've added to one macro button. Is it possible to do something like this? If so, can someone help me get there? Thank you

VBA Code: 
Sub SortCol()

    Dim WS As Worksheet
    Dim rng As Range

    Set WS = ThisWorkbook.Worksheets("Data")

    With WS
        Set rng = .Range("B4:C4" & .Range("C" & .Rows.Count).End(xlUp).Row)
    End With

    rng.Sort Key1:=rng.Columns(2), Order1:=xlAscending, Header:=xlYes
    
    Call Macro2
    
    Call HighlightRangeOfCells
    
    Call PrintArea
    
    'PrintSheet
    
End Sub

Sub Macro2()

    Range("B1:D1").Select
    ActiveCell.FormulaR1C1 = "=TODAY()"
    Range("F2").Select
    
End Sub

Sub HighlightRangeOfCells()
 
  Dim rng As Range
  For Each rng In Range("D5:D93")
    If IsNumeric(rng.Value) Then
      If rng.Value > 1.5 Then
        rng.Interior.Color = vbYellow
     End If
   End If
  Next rng
End Sub

Sub PrintArea()

  Dim lr As Long
  lr = Range("B:C").Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row
  ActiveSheet.PageSetup.PrintArea = "$A$1:$D$" & lr
End Sub


Sub PrintSheet()

    Dim WS As Worksheet

    Set WS = ThisWorkbook.Worksheets("Data")
    WS.PrintOut

End Sub


Screenshot (157).png
 

Excel Facts

When did Power Query debut in Excel?
Although it was an add-in in Excel 2010 & Excel 2013, Power Query became a part of Excel in 2016, in Data, Get & Transform Data.
Sort by date Sort by votes
Hi. I believe that the below will address the TD and Skew conditions and (hopefully) captures the mismatched (unmatched) rows. I was struggling with a way to identify those.

VBA Code: 
Sub HighlightRangeOfCells()

'create loop through rows using 93 as the last row per your orig. code
Dim c As Integer
For c = 5 To 93
    'Will only continue in current row if the sum of columns B:D is not zero
    If Not WorksheetFunction.Sum(Range(Cells(c, 2), Cells(c, 4))) = 0 Then
        'Will check all conditions within current row, ensuring highlighting is added if any
        'conditions are met
        If Cells(c, 4).Value > 1.5 Or Cells(c, 3).Value > 574 Or Cells(c, 3).Value < 554 Then
            Range(Cells(c, 2), Cells(c, 4)).Interior.Color = vbYellow
            'Where conditions are met, reports reason in column E of that row
            If Cells(c, 4).Value > 1.5 Then
                Cells(c, 5).Value = "<-- Skew too high, don't use"
            ElseIf Cells(c, 3).Value > 574 Then
                Cells(c, 5).Value = "<-- TD too high, scrap"
            ElseIf Cells(c, 3).Value < 554 Then
                Cells(c, 5).Value = "<-- TD too low, scrap"
            End If
        End If
    End If
   
    'Will evaluate mismatches. This is dependent on the merged cell for trays having a
    'blank in the second row (i.e.; when unmerged only "A" is reported in cell A5
    'and cell A6 is blank)
    If Cells(c, 1).Value = "" Then
        'checks if current row's column B is blank and columns A and B in the row directly 
        'above are not blank. This should identify the mismatching
        If Cells(c - 1, 1).Value <> "" And Cells(c - 1, 2).Value <> "" _
            And Cells(c, 2).Value = "" Then
                Range(Cells(c - 1, 2), Cells(c - 1, 4)).Interior.Color = vbYellow
                Cells(c - 1, 5).Value = "<-- Unmatched"
        End If
    End If
Next c
End Sub
 
Upvote 0
breynolds0431 said:
Hi. I believe that the below will address the TD and Skew conditions and (hopefully) captures the mismatched (unmatched) rows. I was struggling with a way to identify those.

VBA Code: 
Sub HighlightRangeOfCells()

'create loop through rows using 93 as the last row per your orig. code
Dim c As Integer
For c = 5 To 93
    'Will only continue in current row if the sum of columns B:D is not zero
    If Not WorksheetFunction.Sum(Range(Cells(c, 2), Cells(c, 4))) = 0 Then
        'Will check all conditions within current row, ensuring highlighting is added if any
        'conditions are met
        If Cells(c, 4).Value > 1.5 Or Cells(c, 3).Value > 574 Or Cells(c, 3).Value < 554 Then
            Range(Cells(c, 2), Cells(c, 4)).Interior.Color = vbYellow
            'Where conditions are met, reports reason in column E of that row
            If Cells(c, 4).Value > 1.5 Then
                Cells(c, 5).Value = "<-- Skew too high, don't use"
            ElseIf Cells(c, 3).Value > 574 Then
                Cells(c, 5).Value = "<-- TD too high, scrap"
            ElseIf Cells(c, 3).Value < 554 Then
                Cells(c, 5).Value = "<-- TD too low, scrap"
            End If
        End If
    End If
  
    'Will evaluate mismatches. This is dependent on the merged cell for trays having a
    'blank in the second row (i.e.; when unmerged only "A" is reported in cell A5
    'and cell A6 is blank)
    If Cells(c, 1).Value = "" Then
        'checks if current row's column B is blank and columns A and B in the row directly
        'above are not blank. This should identify the mismatching
        If Cells(c - 1, 1).Value <> "" And Cells(c - 1, 2).Value <> "" _
            And Cells(c, 2).Value = "" Then
                Range(Cells(c - 1, 2), Cells(c - 1, 4)).Interior.Color = vbYellow
                Cells(c - 1, 5).Value = "<-- Unmatched"
        End If
    End If
Next c
End Sub
Click to expand...
Thank you so much. This did the trick. Your code and explanations were really helpful and easy to understand. The "unmatched" condition is tricky and I may just do it manually instead.
 
Upvote 0
breynolds0431 said:
Hi. I believe that the below will address the TD and Skew conditions and (hopefully) captures the mismatched (unmatched) rows. I was struggling with a way to identify those.

VBA Code: 
Sub HighlightRangeOfCells()

'create loop through rows using 93 as the last row per your orig. code
Dim c As Integer
For c = 5 To 93
    'Will only continue in current row if the sum of columns B:D is not zero
    If Not WorksheetFunction.Sum(Range(Cells(c, 2), Cells(c, 4))) = 0 Then
        'Will check all conditions within current row, ensuring highlighting is added if any
        'conditions are met
        If Cells(c, 4).Value > 1.5 Or Cells(c, 3).Value > 574 Or Cells(c, 3).Value < 554 Then
            Range(Cells(c, 2), Cells(c, 4)).Interior.Color = vbYellow
            'Where conditions are met, reports reason in column E of that row
            If Cells(c, 4).Value > 1.5 Then
                Cells(c, 5).Value = "<-- Skew too high, don't use"
            ElseIf Cells(c, 3).Value > 574 Then
                Cells(c, 5).Value = "<-- TD too high, scrap"
            ElseIf Cells(c, 3).Value < 554 Then
                Cells(c, 5).Value = "<-- TD too low, scrap"
            End If
        End If
    End If
  
    'Will evaluate mismatches. This is dependent on the merged cell for trays having a
    'blank in the second row (i.e.; when unmerged only "A" is reported in cell A5
    'and cell A6 is blank)
    If Cells(c, 1).Value = "" Then
        'checks if current row's column B is blank and columns A and B in the row directly
        'above are not blank. This should identify the mismatching
        If Cells(c - 1, 1).Value <> "" And Cells(c - 1, 2).Value <> "" _
            And Cells(c, 2).Value = "" Then
                Range(Cells(c - 1, 2), Cells(c - 1, 4)).Interior.Color = vbYellow
                Cells(c - 1, 5).Value = "<-- Unmatched"
        End If
    End If
Next c
End Sub
Click to expand...
I've just found a small problem that I didn't catch earlier. Some of these conditions have multiple possible outcomes.

For example, if the value in column D is greater than 1.5 AND the values to the left of it in column C are > 574 then the "TD too high, scrap" text must take precedence over the "Skew too high, don't use" text on the right. Similarly, if the same condition in column D is met except the values in column C are < 554 then "TD too low, scrap" must take precedence over the "Skew too high, don't use" text.

The "Skew too high, don't use" text should only be used if two conditions are met. The first is the values in column C must be within the 554-574 range. The second is the difference between them (skew) in column D must be > 1.5 which we have already addressed. I apologize that this is getting rather complicated. If you can help I would greatly appreciate it, if not I completely understand. Cheers
 
Upvote 0
bmt216a said:
Thank you so much. This did the trick. Your code and explanations were really helpful and easy to understand. The "unmatched" condition is tricky and I may just do it manually instead.
Click to expand...
breynolds0431 said:
Hi. I believe that the below will address the TD and Skew conditions and (hopefully) captures the mismatched (unmatched) rows. I was struggling with a way to identify those.

VBA Code: 
Sub HighlightRangeOfCells()

'create loop through rows using 93 as the last row per your orig. code
Dim c As Integer
For c = 5 To 93
    'Will only continue in current row if the sum of columns B:D is not zero
    If Not WorksheetFunction.Sum(Range(Cells(c, 2), Cells(c, 4))) = 0 Then
        'Will check all conditions within current row, ensuring highlighting is added if any
        'conditions are met
        If Cells(c, 4).Value > 1.5 Or Cells(c, 3).Value > 574 Or Cells(c, 3).Value < 554 Then
            Range(Cells(c, 2), Cells(c, 4)).Interior.Color = vbYellow
            'Where conditions are met, reports reason in column E of that row
            If Cells(c, 4).Value > 1.5 Then
                Cells(c, 5).Value = "<-- Skew too high, don't use"
            ElseIf Cells(c, 3).Value > 574 Then
                Cells(c, 5).Value = "<-- TD too high, scrap"
            ElseIf Cells(c, 3).Value < 554 Then
                Cells(c, 5).Value = "<-- TD too low, scrap"
            End If
        End If
    End If
  
    'Will evaluate mismatches. This is dependent on the merged cell for trays having a
    'blank in the second row (i.e.; when unmerged only "A" is reported in cell A5
    'and cell A6 is blank)
    If Cells(c, 1).Value = "" Then
        'checks if current row's column B is blank and columns A and B in the row directly
        'above are not blank. This should identify the mismatching
        If Cells(c - 1, 1).Value <> "" And Cells(c - 1, 2).Value <> "" _
            And Cells(c, 2).Value = "" Then
                Range(Cells(c - 1, 2), Cells(c - 1, 4)).Interior.Color = vbYellow
                Cells(c - 1, 5).Value = "<-- Unmatched"
        End If
    End If
Next c
End Sub
Click to expand...
As for the unmatched condition, only checking for blank cells in the row below the last cell with data is a great idea and should do the trick. If the cells below are blank then it is indeed unmatched. But again, there are multiple possible outcomes. For example, if there are blank cells below the cell with data AND the value in column C is within the 554-574 range, the "Unmatched" text must be used. However, if the same condition is met except the value in column C is > 574 the "TD too high, don't use" text must be used instead. And if the value in column C is < 554 the "TD too low, don't use" text must be used
 
Upvote 0
bmt216a said:
I've just found a small problem that I didn't catch earlier. Some of these conditions have multiple possible outcomes.

For example, if the value in column D is greater than 1.5 AND the values to the left of it in column C are > 574 then the "TD too high, scrap" text must take precedence over the "Skew too high, don't use" text on the right. Similarly, if the same condition in column D is met except the values in column C are < 554 then "TD too low, scrap" must take precedence over the "Skew too high, don't use" text.

The "Skew too high, don't use" text should only be used if two conditions are met. The first is the values in column C must be within the 554-574 range. The second is the difference between them (skew) in column D must be > 1.5 which we have already addressed. I apologize that this is getting rather complicated. If you can help I would greatly appreciate it, if not I completely understand. Cheers
Click to expand...

A simple reordering of the if statements should do it. Basically, if the TD is too low or too high, it won't run into the skew check because the "if" would already be met and reported in the last column. See below where the skew test is the last ElseIf.

VBA Code: 
Sub HighlightRangeOfCells()

'create loop through rows using 93 as the last row per your orig. code
Dim c As Integer
For c = 5 To 93
    'Will check all conditions within row, ensuring highlighting is added if any conditions met
    If Not WorksheetFunction.Sum(Range(Cells(c, 2), Cells(c, 4))) = 0 Then
        If Cells(c, 4).Value > 1.5 Or Cells(c, 3).Value > 574 Or Cells(c, 3).Value < 554 Then
            Range(Cells(c, 2), Cells(c, 4)).Interior.Color = vbYellow
            'Where conditions are met, reports reason to column E
            If Cells(c, 3).Value > 574 Then
                Cells(c, 5).Value = "<-- TD too high, scrap"
            ElseIf Cells(c, 3).Value < 554 Then
                Cells(c, 5).Value = "<-- TD too low, scrap"
            ElseIf Cells(c, 4).Value > 1.5 Then
                Cells(c, 5).Value = "<-- Skew too high, don't use"
            End If
        End If
    End If
    
    'Will evaluate mismatches. This is dependant on the merged cell for trays having a
    'blank in the second row
    If Cells(c, 1).Value = "" Then
        'checks if current row's column B is blank and the row above blank in columns
        'A and B are not blank to identify the mismatching
        If Cells(c - 1, 1).Value <> "" And Cells(c - 1, 2).Value <> "" _
            And Cells(c, 2).Value = "" Then
                Range(Cells(c - 1, 2), Cells(c - 1, 4)).Interior.Color = vbYellow
                Cells(c - 1, 5).Value = "<-- Unmatched"
        End If
    End If
Next c
End Sub
 
Upvote 0
Solution
breynolds0431 said:
A simple reordering of the if statements should do it. Basically, if the TD is too low or too high, it won't run into the skew check because the "if" would already be met and reported in the last column. See below where the skew test is the last ElseIf.

VBA Code: 
Sub HighlightRangeOfCells()

'create loop through rows using 93 as the last row per your orig. code
Dim c As Integer
For c = 5 To 93
    'Will check all conditions within row, ensuring highlighting is added if any conditions met
    If Not WorksheetFunction.Sum(Range(Cells(c, 2), Cells(c, 4))) = 0 Then
        If Cells(c, 4).Value > 1.5 Or Cells(c, 3).Value > 574 Or Cells(c, 3).Value < 554 Then
            Range(Cells(c, 2), Cells(c, 4)).Interior.Color = vbYellow
            'Where conditions are met, reports reason to column E
            If Cells(c, 3).Value > 574 Then
                Cells(c, 5).Value = "<-- TD too high, scrap"
            ElseIf Cells(c, 3).Value < 554 Then
                Cells(c, 5).Value = "<-- TD too low, scrap"
            ElseIf Cells(c, 4).Value > 1.5 Then
                Cells(c, 5).Value = "<-- Skew too high, don't use"
            End If
        End If
    End If
   
    'Will evaluate mismatches. This is dependant on the merged cell for trays having a
    'blank in the second row
    If Cells(c, 1).Value = "" Then
        'checks if current row's column B is blank and the row above blank in columns
        'A and B are not blank to identify the mismatching
        If Cells(c - 1, 1).Value <> "" And Cells(c - 1, 2).Value <> "" _
            And Cells(c, 2).Value = "" Then
                Range(Cells(c - 1, 2), Cells(c - 1, 4)).Interior.Color = vbYellow
                Cells(c - 1, 5).Value = "<-- Unmatched"
        End If
    End If
Next c
End Sub
Click to expand...
I didn't realize it was that simple. It worked just as expected. Thank you. What would I have to do to do the same for the code of the unmatched condition? Meaning, before that portion of code is executed, I would like the TD too high or TD too low conditions to be checked for and identify values that are out of the 554-574 range before the unmatched condition is run.
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Question Question
Clock in and out 2 breaks and a lunch
Replies
0
Views
135
Aiden Jenner
A
S
  • Question Question
Lock Script misses first Range
2
Replies
10
Views
100
Micron
M
S
  • Solved
Delete rows that contain highlighting
Replies
5
Views
112
Serafin54
S
K
  • Question Question
Range of columns change colors based on cell column value
Replies
3
Views
59
Joe4
Joe4
U
  • Solved
Rewrite Code as a Sub to work on Active Sheet
Replies
2
Views
53
Skyybot
Skyybot

Forum statistics

Threads
1,224,823
Messages
6,181,171
Members
453,021
Latest member
Justyna P

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