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

**KjBox** · Dec 11th 2016

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

No, code in last post still not right, this should be though. Any value change within any grid or a change to AT2 will redo the font colors.

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 [at2] > 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

Sorry to be slow in coming back to you as at last got into VB Editor. Nearly there works fine but above AT6 if there are say 3 equal 1st nos or 2 equal 2nd nos it returns them all in Red (more than 2) if you follow and the same if it's meant to be 1 Red no.

**KjBox** · Dec 12th 2016

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

Sorry to also be slow in replying, it was 1AM when I last replied and I went to sleep soon after that!

Try this, I have added another variable that counts the number of fonts changed to red for each grid and the code exits each grid check when the count reches 2.

Code

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim x, i As Integer, ii As Integer, iii As Integer
    Dim 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
            ii = 0: iii = 0
            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 [at2] > 5 Then
                    For Each r In .Cells
                        If r = d1 And ii <> 2 Then
                            r.Font.Color = vbRed
                            ii = ii + 1
                            If ii + iii = 2 Then Exit For
                        End If
                        If r = d2 And iii <> 1 Then
                            r.Font.Color = vbRed
                            iii = iii + 1
                        End If
                    Next
                Else
                    For Each r In .Cells
                        If r = d1 Then
                            r.Font.Color = vbRed
                            ii = ii + 1
                            If ii = 2 Then Exit For
                        End If
                    Next
                End If
           End With
        Next
    End If


End Sub

Display More

weebilko · Dec 12th 2016

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

Sorry you were up so late don't stay up late tonight. We are nearly there the 2 Red numbers work fine but when it's for a singe Red if you have say 2 duplicated numbers (say the 2 highest numbers are 22) then both turn Red instead of a single turning Red. Regards

**KjBox** · Dec 13th 2016

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

Sorry I misread your explanation, I thought there always had to be 2 values in red.Try changing the code to this, the d2 formula needed to be changed so that the second largest value is obtained even when the largest value is duplicated.

Code

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim x, i As Integer, ii As Integer, iii As Integer
    Dim 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
            ii = 0: iii = 0
            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 [at2] > 5 Then
                    For Each r In .Cells
                        If r = d1 And ii <> 1 Then
                            r.Font.Color = vbRed
                            ii = ii + 1
                            If ii + iii = 2 Then Exit For
                        End If
                        If r = d2 And iii <> 1 Then
                            r.Font.Color = vbRed
                            iii = iii + 1
                        End If
                    Next
                Else
                    For Each r In .Cells
                        If r = d1 Then
                            r.Font.Color = vbRed
                            Exit For
                        End If
                    Next
                End If
           End With
        Next
    End If


End Sub

Display More

weebilko · Dec 13th 2016

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

I’m sorry not quite there yet; say AT2 is set at 7 (2 nos) and you input 3, 4, 5, 5 into the grid this happens 3, 4 (red), 5 (red), 5 but it should be 3, 4, 5 (red), 5 (red) and if TT2 is set at 5 (1 no) if you insert say 4,4 then it seems to work in that 1 no turns red but there is a Run-time error at L3?

I don’t know if I can explain it more fully or should I send you a ‘sample’ worksheet?

**KjBox** · Dec 13th 2016

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

I am getting confused about what is to turn red and when!

As I understand it now:

AT2 = 4 or 5
1st. instance of largest number to have red font.

AT2 = 6 to 10
Largest number is not duplicated
1st. instance of largest number to have red font and 1st. instance of 2nd largest number to have red font.
Largest number is duplicated
1st. and 2nd. instances of largest number to have red font.

Is that correct?

I do not get the error you mention.

weebilko · Dec 13th 2016

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

Yes that's it.

**KjBox** · Dec 13th 2016

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

OK, at last
Try this, file attached to show it working.

Code

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim x, i As Integer, ii As Integer, iii As Integer
    Dim 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
            ii = 0: iii = 0
            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 [at2] > 5 Then
                    For Each r In .Cells
                        If r = d1 And ii <> 2 Then
                            r.Font.Color = vbRed
                            ii = ii + 1
                            If ii + iii = 2 Then Exit For
                        End If
                        If r = d2 And iii <> 1 Then
                            r.Font.Color = vbRed
                            iii = iii + 1
                        End If
                    Next
                Else
                    For Each r In .Cells
                        If r = d1 Then
                            r.Font.Color = vbRed
                            Exit For
                        End If
                    Next
                End If
           End With
        Next
    End If


End Sub

Display More

weebilko · Dec 13th 2016

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

Yep, yep that's it, sorry it was all about my poor communications. Very grateful.

**KjBox** · Dec 13th 2016

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

No need to be sorry, and you're welcome.

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

Participate now!

Share

Users Viewing This Thread