Solved

Compare Excel cells and highlight

Posted on 2015-01-25
12
140 Views
Last Modified: 2015-01-26
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
0
Comment
Question by:W.E.B
  • 6
  • 4
  • 2
12 Comments
 
LVL 12

Expert Comment

by:FarWest
ID: 40569321
maybe you don't need VBA to do so
check condition formating-->color scales option
0
 

Author Comment

by:W.E.B
ID: 40569327
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
 
LVL 12

Expert Comment

by:FarWest
ID: 40569359
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
Free Tool: Port Scanner

Check which ports are open to the outside world. Helps make sure that your firewall rules are working as intended.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

 

Author Comment

by:W.E.B
ID: 40569375
Hello,
safe to say 1500 is the Max Rows.
thanks
0
 
LVL 12

Expert Comment

by:FarWest
ID: 40569469
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
 
LVL 5

Expert Comment

by:Hakan Yılmaz
ID: 40569470
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
 

Author Comment

by:W.E.B
ID: 40569489
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
 
LVL 12

Accepted Solution

by:
FarWest earned 500 total points
ID: 40569499
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
 

Author Comment

by:W.E.B
ID: 40569515
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
 

Author Comment

by:W.E.B
ID: 40569516
All good.
I got it
thanks
0
 

Author Closing Comment

by:W.E.B
ID: 40569517
Thank you very Much.
0
 
LVL 5

Expert Comment

by:Hakan Yılmaz
ID: 40570239
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

Featured Post

Announcing the Most Valuable Experts of 2016

MVEs are more concerned with the satisfaction of those they help than with the considerable points they can earn. They are the types of people you feel privileged to call colleagues. Join us in honoring this amazing group of Experts.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

If you need to start windows update installation remotely or as a scheduled task you will find this very helpful.
Freeze panes is an option within all variants of Excel to enable parts of a sheet to remain stationary when the cursor is in another part of the sheet. This is a very useful feature which is overlooked or under used.
This Micro Tutorial demonstrates in Microsoft Excel how to consolidate your marketing data by creating an interactive charts using form controls. This creates cool drop-downs for viewers of your chart to choose from.
Although Jacob Bernoulli (1654-1705) has been credited as the creator of "Binomial Distribution Table", Gottfried Leibniz (1646-1716) did his dissertation on the subject in 1666; Leibniz you may recall is the co-inventor of "Calculus" and beat Isaac…

856 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question