Compare Excel cells and highlight

Hello,
Can you please help.
I need a macro code to compare cells (Column D) and highlight the lowest cell values (Columns F,G,H).
Please see sample attached.

Example:
B3k ---- Highlight   F3,  G25,  H25
K1C ---- Highlight   F54,  G31,  H4

Any help is appreciated.
Thanks,
Sample.xlsx
W.E.BAsked:
Who is Participating?
 
FarWestCommented:
done
Public Sub FindMin()
Dim ii As Integer
Dim ws As Worksheet
Set ws = ActiveSheet
Dim DataRange As Range
Set DataRange = ws.UsedRange
For ii = 1 To DataRange.Rows.Count
ws.Cells(ii, 11) = ii '11 means K in column name
Next
'here we change sort
      DataRange.Sort Key1:=ws.Range("D1"), Order1:=xlAscending, Header:=xlNo, _
            OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
            DataOption1:=xlSortNormal

Dim cDelivery As String
cDelivery = "NULL"
Dim cx1r As Range, cx2r, cx3r
DataRange.Range("F:H").Interior.Color = vbWhite
For ii = 1 To DataRange.Rows.Count
If ws.Range("F" + Trim(CStr(ii))).Value <> "x1" Then
If cDelivery <> UCase(ws.Range("D" + Trim(CStr(ii))).Value) Then
If cDelivery <> "NULL" Then
cx1r.Interior.Color = vbYellow
cx2r.Interior.Color = vbYellow
cx3r.Interior.Color = vbYellow
End If
cDelivery = UCase(ws.Range("D" + Trim(CStr(ii))).Value)
Set cx1r = ws.Range("F" + Trim(CStr(ii)))
Set cx2r = ws.Range("G" + Trim(CStr(ii)))
Set cx3r = ws.Range("H" + Trim(CStr(ii)))
End If
If cx1r.Value > ws.Range("F" + Trim(CStr(ii))).Value Then Set cx1r = ws.Range("F" + Trim(CStr(ii)))
If cx2r.Value > ws.Range("G" + Trim(CStr(ii))).Value Then Set cx2r = ws.Range("G" + Trim(CStr(ii)))
If cx3r.Value > ws.Range("H" + Trim(CStr(ii))).Value Then Set cx3r = ws.Range("H" + Trim(CStr(ii)))
'ws.Cells(ii, 1) = ii
End If
Next
'here we revert sort
      DataRange.Sort Key1:=ws.Range("K1"), Order1:=xlAscending, Header:=xlNo, _
            OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
            DataOption1:=xlSortNormal


End Sub

Open in new window

0
 
FarWestCommented:
maybe you don't need VBA to do so
check condition formating-->color scales option
0
 
W.E.BAuthor Commented:
Hello,
The number of Rows varies. (Between couple hundred and few thousands).
I need to inject the VBA to another VBA used on the sheet.

thanks,
0
Cloud Class® Course: MCSA MCSE Windows Server 2012

This course teaches how to install and configure Windows Server 2012 R2.  It is the first step on your path to becoming a Microsoft Certified Solutions Expert (MCSE).

 
FarWestCommented:
aha, I got it,
for performance issue and easy code it s better making temporary sort on Delivery in the sheet (this requires adding line number to revert to original sort after complete,
is there any limitation to do so?
0
 
W.E.BAuthor Commented:
Hello,
safe to say 1500 is the Max Rows.
thanks
0
 
FarWestCommented:
check this code
Public Sub FindMin()
Dim ii As Integer
Dim ws As Worksheet
Set ws = ActiveSheet
Dim DataRange As Range
Set DataRange = ws.UsedRange
For ii = 1 To DataRange.Rows.Count
ws.Cells(ii, 1) = ii
Next
      DataRange.Sort Key1:=ws.Range("D1"), Order1:=xlAscending, Header:=xlNo, _
            OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
            DataOption1:=xlSortNormal

Dim cDelivery As String
cDelivery = "NULL"
Dim cx1r As Range, cx2r, cx3r
DataRange.Range("F:H").Interior.Color = vbWhite
For ii = 1 To DataRange.Rows.Count
If ws.Range("F" + Trim(CStr(ii))).Value <> "x1" Then
If cDelivery <> UCase(ws.Range("D" + Trim(CStr(ii))).Value) Then
If cDelivery <> "NULL" Then
cx1r.Interior.Color = vbYellow
cx2r.Interior.Color = vbYellow
cx3r.Interior.Color = vbYellow
End If
cDelivery = UCase(ws.Range("D" + Trim(CStr(ii))).Value)
Set cx1r = ws.Range("F" + Trim(CStr(ii)))
Set cx2r = ws.Range("G" + Trim(CStr(ii)))
Set cx3r = ws.Range("H" + Trim(CStr(ii)))
End If
If cx1r.Value > ws.Range("F" + Trim(CStr(ii))).Value Then Set cx1r = ws.Range("F" + Trim(CStr(ii)))
If cx2r.Value > ws.Range("G" + Trim(CStr(ii))).Value Then Set cx2r = ws.Range("G" + Trim(CStr(ii)))
If cx3r.Value > ws.Range("H" + Trim(CStr(ii))).Value Then Set cx3r = ws.Range("H" + Trim(CStr(ii)))
'ws.Cells(ii, 1) = ii
End If
Next
      DataRange.Sort Key1:=ws.Range("A1"), Order1:=xlAscending, Header:=xlNo, _
            OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
            DataOption1:=xlSortNormal


End Sub

Open in new window

0
 
Hakan YılmazTechnical Office MEP EngineerCommented:
please try this.
select the cells you want to be checked&painted (say F2:H56), then run code.
(It will ignore texts and empty cells in the range you select.)

It will compare values within groups in column d.

Sub hakan()
    Dim myrange As Range
    Dim mysheet As Worksheet
    Dim fixcolumn As Range
    Dim itercolumn As Range
    Dim itercell As Range

    Set myrange = Selection
    Set mysheet = myrange.Worksheet
    Set fixcolumn = mysheet.Columns(4)
    
    With myrange.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    
    For Each itercell In myrange.Cells
        If (Not IsEmpty(itercell.Value2)) And IsNumeric(itercell.Value2) Then
            Set itercolumn = itercell.EntireColumn
            If Application.WorksheetFunction.CountIfs(fixcolumn, fixcolumn.Rows(itercell.Row), itercolumn, "<" & Val(itercell.Value2)) = 0 Then
                itercell.Interior.Color = RGB(255, 0, 0)
            End If
        End If
    Next itercell
End Sub

Open in new window

0
 
W.E.BAuthor Commented:
Hi Farwest,
thank you,
The code is replacing my data in column A with the sorting numbers.

can you please use a different Column? say Column "K"?

Hakan,
your code is not doing anything.

Thanks,
0
 
W.E.BAuthor Commented:
Hi Farwest,
I thank you very much for your help,
I made a mistake,
I have some data under Column "k"

I tried to change to Column "T" ----- ws.Cells(ii, 20) = ii '11 means K in column name
But it doesn't sort properly.

can you please help ,
sorry about this.
thanks
0
 
W.E.BAuthor Commented:
All good.
I got it
thanks
0
 
W.E.BAuthor Commented:
Thank you very Much.
0
 
Hakan YılmazTechnical Office MEP EngineerCommented:
I revised code to replace decimal separator from "," to "." to use in vba.
Please try this too.
It will work even if you increase number of columns to mark minimums.
Sub hakan()
    Dim myrange As Range
    Dim mysheet As Worksheet
    Dim fixcolumn As Range
    Dim itercolumn As Range
    Dim itercell As Range

    Set myrange = Selection
    Set mysheet = myrange.Worksheet
    Set fixcolumn = mysheet.Columns(4)
    
    With myrange.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    
    For Each itercell In myrange.Cells
        If (Not IsEmpty(itercell.Value2)) And IsNumeric(itercell.Value2) Then
            Set itercolumn = itercell.EntireColumn
            If Application.WorksheetFunction.CountIfs(fixcolumn, fixcolumn.Rows(itercell.Row), itercolumn, "<" & Replace(itercell.Value2, ",", ".")) = 0 Then
                itercell.Interior.Color = RGB(255, 0, 0)
            End If
        End If
    Next itercell
End Sub

Open in new window

0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.