Macro to find/return 1 or 2 highest values in Red in a spreadsheet grid

weebilko · Dec 7th 2016

I have a grid H4:Y8 in a spreadsheet in which various values are entered, some may be duplicated and I have a VBA macro (.docx attached) which will find only the 2 highest numbers and returns them in red and even if there are duplicate numbers it will still only find a maximum of 2 and it works fine.

I now wish to expand it so that if I enter a value between and including 4 to 10 into cell AT2 and if it is less than 6 then a macro will find only the single highest number (even if the numbers are duplicated) in the grid and the number will be changed from black to red but if the number entered into AT2 is more than 5 then only the 2 highest numbers, again even if there are duplicates, are changed to red, as now.

I would be very grateful if anyone can help increase the scope of the macro and I hope I have explained it sufficiently without attaching the actual spreadsheet file which is large.

Regards

fess · Dec 8th 2016

Re: Macro to find/return 1 or 2 highest values in Red in a spreadsheet grid

Silly reply. I will think a bit more

**StephenR** · Dec 8th 2016

Re: Macro to find/return 1 or 2 highest values in Red in a spreadsheet grid

Could you post a workbook with a small sample of data and your current code?

weebilko · Dec 8th 2016

Re: Macro to find/return 1 or 2 highest values in Red in a spreadsheet grid

Thanks for looking will need to create a sample as original is too large and post it tomorrow Regards

Edited(New info) I also realise that I have sent the wrong macro .docx so let me rethink the project and send an fie copy.

fess · Dec 8th 2016

Re: Macro to find/return 1 or 2 highest values in Red in a spreadsheet grid

I had a quick look yesterday and posted up a partial answer - then re read your explanation and changed my mind. I think you are almost there and am wondering if a Select Case approach would work. I do not expect to get time to look at it before the weekend but if I do I will have some fun

I am a bit confused at your criteria though. AT2 would be between 4 and 10 - ok I get that. But then it has to trigger a macro if it is under 6 and trigger a different macro if it is over 5. Isn't it easier to just trigger if the value is > 5?

fess · Dec 9th 2016

Re: Macro to find/return 1 or 2 highest values in Red in a spreadsheet grid

I had a play. I changed AT2 to F4 as I did not want to scroll across all the time to test it. You would just have to add your own cases to fit your criteria. I am sure the more experienced ones here can help you compress the code but I am not good with loops so I duplicated the code you had.

Code

Sub Max2Numbers()
Dim inrng As Range
Dim score As Integer
Application.ScreenUpdating = False
Set inrng = Range("H4:Y8")
score = Range("F4").Value
inrng.Font.ColorIndex = xlAutomatic
inrng.Font.Bold = False
Firstrow = inrng.Cells(1, 1).Row
Lastrow = inrng(inrng.Count).Row
FirstCol = inrng.Cells(1, 1).Column
LastCol = inrng(inrng.Count).Column
L1 = WorksheetFunction.Large(inrng, 1)
L2 = WorksheetFunction.Large(inrng, 2)


Select Case score
    Case Is < 5
        For r = Firstrow To Lastrow
            For c = FirstCol To LastCol
                If Cells(r, c) = L1 Then
                    Cells(r, c).Font.Bold = True
                    Cells(r, c).Font.Color = -16776961
                    L1 = -99
                End If
            Next c
        Next r
    
    
    Case Is >= 5
        For r = Firstrow To Lastrow
            For c = FirstCol To LastCol
                If Cells(r, c) = L1 Then
                    Cells(r, c).Font.Bold = True
                     Cells(r, c).Font.Color = -16776961
                     L1 = -99
                Else
    
                If Cells(r, c) = L2 Then
                    Cells(r, c).Font.Bold = True
                    Cells(r, c).Font.Color = -16776961
                    L2 = -99
                End If
            End If
        Next c
    Next r
End Select
Application.ScreenUpdating = True
End Sub

Display More

weebilko · Dec 9th 2016

Re: Macro to find/return 1 or 2 highest values in Red in a spreadsheet grid

Many thanks fess, yes you are correct re the >5 sometimes you don't see the 'bleeding obvious'. OK will have a play around and get back to you, once again many thanks. Regards

weebilko · Dec 9th 2016

Re: Macro to find/return 1 or 2 highest values in Red in a spreadsheet grid

Many thanks fess works great, just a couple of things that you could maybe help me with:

1. You are correct the macro should be triggered when it is >5 (single red when 5 or under 2 reds when 6 or over) so can you amend please.

2. There will be 9 similar but separate grids (1 that your macro will cover + 8 others) and wonder if I can just use your macro and set up the 8 others by renaming the macro and changing the ‘range’ to suit.

Very grateful when you can find the time to amend. Regards

fess · Dec 9th 2016

Re: Macro to find/return 1 or 2 highest values in Red in a spreadsheet grid

Hmmm. In response to your question 1. Looking at the code the answer to your question is so obvious I am wondering if you looked at it or understood it at all. You simply need to change the 5 to a 6.

Question 2. Will all 9 grids listen to AT2 or will they all look at different cells? Yes, the obvious and quick solution is to repeat the code for each grid. My VBA skills are very much in the realm of beginner so creating loops to go through each grid is probably beyond me at the moment

fess · Dec 10th 2016

Re: Macro to find/return 1 or 2 highest values in Red in a spreadsheet grid

ok I had a bit of fun. This will loop through a series of ranges and choose either the highest value or the top 2 values based on if your test value is >=6. Note it will choose the top values across ALL the ranges and not in each range.

Code

Sub FessHadFun()
Dim r As Range, c As Range
Dim score As Integer, L1 As Integer, L2 As Integer


Set r = Application.Union(Range("G2:H4"), Range("J2:K4"), Range("G6:H8"), Range("J6:K8")) 'this sets up the ranges.  I have 4 you just add as you need to
r.Interior.ColorIndex = 0  'set the interior colour to blank
score = Range("E3").Value  'this is the cell which value you are using to decide if it is >5
L1 = Application.WorksheetFunction.Large(r, 1)
L2 = Application.WorksheetFunction.Large(r, 2)
    Select Case score
    Case Is >= 6        ' You can make this number any value you like.  Code will fire if 'score' >= that value
    For Each c In r                            'check each cell in each range.  Loops through the ranges
        If c.Value = L1 Then
                 c.Interior.ColorIndex = 3
        Else
            If c.Value = L2 Then
                c.Interior.ColorIndex = 4
            End If
       End If
    Next
    
    Case Is < 6                                ' second case.  this time fires if less than the value.  If you want more cases just add them on following this code as a template
        For Each c In r
            If c.Value = L1 Then
                 c.Interior.ColorIndex = 3
            End If
    Next
     
End Select
End Sub

Display More

**KjBox** · Dec 10th 2016

Re: Macro to find/return 1 or 2 highest values in Red in a spreadsheet grid

You have not said what ranges the 9 Grids cover. In the attached file I have just used 9 different ranges for the grids. Note that each grid is a named range ("Grid1", "Grid2","Grid3" ......."Grid9").

Also your code showed that you wanted the font color changed to red not the cell fill, is that correct?

It will not matter where your actual grids are but you must give each grid a defined name ("Grid1", "Grid2","Grid3" .... etc.). the code will then work no matter the range of each grid.

I have also included Data Validation for cell AT2 so only whole numbers between 4 and 10 inclusive can be entered.

The code below is in the Worksheet object module for the sheet with the grids and will be triggered when the value of Cell AT2 changes, it treats each grid individually.

Code

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim x, i As Integer, d1 As Double, d2 As Double, r As Range
    
    If Not Intersect(Target, [AT2]) Is Nothing Then
        For i = 1 To 9
            With Range("Grid" & i)
                d1 = Application.Large(.Cells, 1)
                d2 = Application.Large(.Cells, 2)
                .Cells.Font.Color = vbBlack
                If Target > 5 Then
                    For Each r In .Cells
                        If r = d1 Or r = d2 Then r.Font.Color = vbRed
                    Next
                Else
                    For Each r In .Cells
                        If r = d1 Then r.Font.Color = vbRed
                    Next
                End If
           End With
        Next
    End If


End Sub

Display More

I you want to color the cell fill rather than font color then replace the code with this (make sure you set all cells to font color automatic)

Code

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim x, i As Integer, d1 As Double, d2 As Double, r As Range
    
    If Not Intersect(Target, [AT2]) Is Nothing Then
        For i = 1 To 9
            With Range("Grid" & i)
                d1 = Application.Large(.Cells, 1)
                d2 = Application.Large(.Cells, 2)
                .Cells.Interior.Color = xlNone
                If Target > 5 Then
                    For Each r In .Cells
                        If r = d1 Or r = d2 Then r.Interior.Color = vbRed
                    Next
                Else
                    For Each r In .Cells
                        If r = d1 Then r.Interior.Color = vbRed
                    Next
                End If
           End With
        Next
    End If


End Sub

Display More

weebilko · Dec 11th 2016

Re: Macro to find/return 1 or 2 highest values in Red in a spreadsheet grid

Thanks for all your help and that is a neat ‘looping ranges’ file fess. I attach your sample workbook KjBox with my intended layout but can’t seem to get it work, no doubt it’s me. Can you have a look please. Regards

**KjBox** · Dec 11th 2016

Re: Macro to find/return 1 or 2 highest values in Red in a spreadsheet grid

You had some of the named ranges referring to an incorrect range.

I see that "Grid 3"has only 4 rows whereas all the others have 5, is that correct? If not, then you will need to redo the "Grid3" defined name to refer to the increased range after you add a 5th row to "Grid 3".

I have included a check in the code to see if there are either no numbers or just one number in a grid, that will stop the Application.Large functions from returning an error.

**KjBox** · Dec 11th 2016

Re: Macro to find/return 1 or 2 highest values in Red in a spreadsheet grid

I just saw that the formula to get the 2nd largest value fails when the largest value is duplicated.

Here is the file with that fixed.

This is the code with the revised formula

Code

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim x, i As Integer, d1 As Double, d2 As Double, r As Range
    
    If Not Intersect(Target, [AT2]) Is Nothing Then
        For i = 1 To 9
            With Range("Grid" & i)
                If Application.Count(.Cells) > 1 Then
                    d1 = Application.Large(.Cells, 1)
                    d2 = Application.Large(.Cells, Application.CountIf(.Cells, Application.Max(.Cells)) + 1)
                ElseIf Application.Count(.Cells) > 0 Then
                    d1 = Application.Large(.Cells, 1)
                    d2 = 0
                End If
                .Cells.Font.Color = vbBlack
                If Target > 5 Then
                    For Each r In .Cells
                        If r = d1 Or r = d2 Then r.Font.Color = vbRed
                    Next
                Else
                    For Each r In .Cells
                        If r = d1 Then r.Font.Color = vbRed
                    Next
                End If
           End With
        Next
    End If


End Sub

Display More

weebilko · Dec 11th 2016

Re: Macro to find/return 1 or 2 highest values in Red in a spreadsheet grid

I'm sorry we seem to be at cross purposes as if there are say 2 equal high nos these 2 should be returned but not the next highest. There should only ever be 2 nos in total in red if over 5 in AT2 and only ever 1 if below. PS I cant seem to find the macros? and all grids should have 5 rows.

**KjBox** · Dec 11th 2016

Re: Macro to find/return 1 or 2 highest values in Red in a spreadsheet grid

Ahhh OK I thought that if AT2 was >5 then the largest number AND the second largest must change to red font even if one or both were duplicated.

Here is the file as you need, the macro is in the Worksheet Object Module. In the VB Editor double click "Sheet1(Sheet1)"

I have increased the size of "Grid 3" to 5 rows and amended the "Grid3" named range.

weebilko · Dec 11th 2016

Re: Macro to find/return 1 or 2 highest values in Red in a spreadsheet grid

Thanks but sorry I just deleted your nos in Grid 1 and re-entered 4 of my own at random and everyone turned Red?

**KjBox** · Dec 11th 2016

Re: Macro to find/return 1 or 2 highest values in Red in a spreadsheet grid

It does not do that for me. If you change the value in AT2 do the new values in Grid 1 color correctly?

weebilko · Dec 11th 2016

Re: Macro to find/return 1 or 2 highest values in Red in a spreadsheet grid

Yes, but if I then put in another higher no that one doesn't turn Red but the 2 lower ones stay Red.

**KjBox** · Dec 11th 2016

Re: Macro to find/return 1 or 2 highest values in Red in a spreadsheet grid

OK,I did not realise you needed the code to run when grid values were changed as well as AT2 changing, I thought just AT2.

Try changing the code to this

Code

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim x, i As Integer, d1 As Double, d2 As Double, r As Range
    
    If Not Intersect(Target, [AT2]) Is Nothing _
    Or Not Intersect(Target, [Grid1]) Is Nothing _
    Or Not Intersect(Target, [Grid2]) Is Nothing _
    Or Not Intersect(Target, [Grid3]) Is Nothing _
    Or Not Intersect(Target, [Grid4]) Is Nothing _
    Or Not Intersect(Target, [Grid5]) Is Nothing _
    Or Not Intersect(Target, [Grid6]) Is Nothing _
    Or Not Intersect(Target, [Grid7]) Is Nothing _
    Or Not Intersect(Target, [Grid8]) Is Nothing _
    Or Not Intersect(Target, [Grid9]) Is Nothing Then
        For i = 1 To 9
            With Range("Grid" & i)
                If Application.Count(.Cells) > 1 Then
                    d1 = Application.Large(.Cells, 1)
                    d2 = Application.Large(.Cells, 2)
                ElseIf Application.Count(.Cells) > 0 Then
                    d1 = Application.Large(.Cells, 1)
                    d2 = 0
                End If
                .Cells.Font.Color = vbBlack
                If Target > 5 Then
                    For Each r In .Cells
                        If r = d1 Or r = d2 Then r.Font.Color = vbRed
                    Next
                Else
                    For Each r In .Cells
                        If r = d1 Then r.Font.Color = vbRed
                    Next
                End If
           End With
        Next
    End If


End Sub

Display More

Macro to find/return 1 or 2 highest values in Red in a spreadsheet grid

Participate now!

Share