Hightlight Row Range if Criteria is Satisfied

[Gos-C]

Hi all,

I need the following code to highlight A:EF if the row has the value 4000 or 4500 in column J. It does that.

The function checks if a corresponding record, which indicate void, is found - F, G and CE will be the same as the original record. If one is found, I want the code to highlight A:EF of the original record.

I need some help to fix the red portion of the code, please. I can't figure out how to code it.

Sub Highlight_Exclusions()
    Dim oLastRow As Long
    Dim c As Range, hRng As Range, n As Long
'    Const CC As Integer = 3 * 26 + 3     'column 'CC' as a number
    Const A As Integer = 1     'column 'G' as a number
'    Const EC As Integer = 5 * 26 + 3     'column 'EC' as a number
    Const EF As Integer = 5 * 26 + 6     'column 'EF' as a number
    Const J As Integer = 10     'column 'J' as a number

    Application.ScreenUpdating = False
    
    oLastRow = Cells.SpecialCells(xlLastCell).Row  'report original lastrow
    
    For n = 2 To oLastRow
        Set c = ActiveSheet.Cells(n, J)    'set range to row n, column J
        Set hRng = ActiveSheet.Range(Cells(n, A), Cells(n, EF))   'set range to row n, column G
        If c.Value = 4000 Or c.Value = 4500 Then     '4000 & 4500 claim
    hRng.Interior.ColorIndex = 36
    
   [COLOR="#FF0000"][B]For Each hRng In ActiveSheet
   If CheckF_G_CE(Range("F" & Target.Row), Range("G" & Target.Row), _
               Range("CE" & Target.Row), Target.Row) Then
    hRng.Interior.ColorIndex = 36
    End If
    Next n
    
   End If
   Next hRng
[/B][/COLOR]   
   Application.ScreenUpdating = True
End Sub

Public Function CheckF_G_CE(Fstr As String, Gstr As String, _
                         CEstr As String, Rw As Long) As Boolean
    Dim vFIND As Range

    On Error Resume Next
    Set vFIND = Range("F:F").Find(Fstr, After:=Range("F" & Rw), LookIn:=xlValues, LookAt:=xlWhole)
        If Not vFIND Is Nothing Then
            Do Until vFIND.Row = Rw
                If Range("G" & vFIND.Row) = Gstr And _
                   Range("CE" & vFIND.Row) = CEstr Then ' And _
                    CheckF_G_CE = True
                    Exit Function
                End If
                Set vFIND = Range("F:F").FindNext(vFIND)
            Loop
        End If
   ' by default if we reach this point, the result is FALSE, no duplicates found
    End Function

Thank you,
Gos-C

 

[farmerscott]

This code uses Col EH to show the matches. 1&1 are matches, 2 (only) does not match, 3&3 are matches, etc.

Sub Highlight_Exclusions()
    Dim oLastRow As Long
    Dim c As Range, hRng As Range, n As Long, cel As Range
    Dim text As String
    Dim x As Long
    Dim d As Range
    
    
    
'    Const CC As Integer = 3 * 26 + 3     'column 'CC' as a number
    Const A As Integer = 1     'column 'G' as a number
'    Const EC As Integer = 5 * 26 + 3     'column 'EC' as a number
    Const EF As Integer = 5 * 26 + 6     'column 'EF' as a number
    Const J As Integer = 10     'column 'J' as a number
    Application.ScreenUpdating = False
    
    oLastRow = Cells.SpecialCells(xlLastCell).Row  'report original lastrow
    counter = 0
    
    Range("EG2:EG" & oLastRow).FormulaR1C1 = "=concatenate(RC[-130],RC[-131],RC[-54])"
    
    
    For n = 2 To oLastRow
        Set c = ActiveSheet.Cells(n, J)    'set range to row n, column J
        Set hRng = ActiveSheet.Range(Cells(n, A), Cells(n, EF))   'set range to row n, column G
        If c.Value = 4000 Or c.Value = 4500 Then     '4000 & 4500 claim
            hRng.Interior.ColorIndex = 36
            
            counter = counter + 1
            text = c.Offset(0, 127).Value
            c.Offset(0, 128).Value = counter
        For x = 2 To oLastRow
                Set d = ActiveSheet.Cells(x, 137)
                Set hRng = ActiveSheet.Range(Cells(x, A), Cells(x, EF))
                If d.Value = text And d.Offset(, -2).Value = "Paid" Then
                hRng.Interior.Color = vbRed
                counter = counter
                
                d.Offset(, 1).Value = counter
                
                End If
        Next x
        
        End If
        
    Next n
    
  Range("EG2:EG" & oLastRow).ClearContents
   
   
   
   Application.ScreenUpdating = True
End Sub

 

[Gos-C]

Hi farmerscott,

Sorry for the delayed response - I was very busy yesterday.

From my initial check of the code, it appears to work - at least to the point where I can modify it. Thank you very much for taking the time to help me.

Kindest regards,
Gos-C

 

[farmerscott]

Glad to help.

Come back if you need help, hopefully I can assist.