Solved

Compare Excel cells and highlight

Posted on 2015-01-25
12
139 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
ScreenConnect 6.0 Free Trial

Check out the updates in one game-changing release, ScreenConnect 6.0, based on partner feedback. New features include a redesigned UI that improves session organization and overall user experience. See the enhancements for yourself!

 

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

PRTG Network Monitor: Intuitive Network Monitoring

Network Monitoring is essential to ensure that computer systems and network devices are running. Use PRTG to monitor LANs, servers, websites, applications and devices, bandwidth, virtual environments, remote systems, IoT, and many more. PRTG is easy to set up & use.

Question has a verified solution.

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

This article is the result of a quest to better understand Task Scheduler 2.0 and all the newer objects available in vbscript in this version over  the limited options we had scripting in Task Scheduler 1.0.  As I started my journey of knowledge I f…
If you need to start windows update installation remotely or as a scheduled task you will find this very helpful.
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.
This lesson covers basic error handling code in Microsoft Excel using VBA. This is the first lesson in a 3-part series that uses code to loop through an Excel spreadsheet in VBA and then fix errors, taking advantage of error handling code. This l…

803 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