Finding row numbers of the top 10 largest numbers in a range

[Mann750]

Hi,

I have been using the Application.WorksheetFunction.Large to find the top 10 numbers in a range but I cannot seem to get the rest of the code to find the corresponding row number when there are duplicate values. My code so far is as below:

Sub Top10Values()
Dim rngTestArea As Range, k As Integer, j As Long, MyResult As String, rowcount As Long, lastrow as long
Dim report As Worksheet, register As Worksheet

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

Set report = Worksheets("REPORT")
Set register = Worksheets("Register")

lastrow = register.Cells(Rows.Count, 17).End(xlUp).Row
Set rngTestArea = register.Range("Q2:Q" & lastrow)
j = 0
For k = 1 To 10
    j = Application.WorksheetFunction.Large(rngTestArea, k)
        If j > 0 Then
        rowcount = register.Columns(17).Find(what:=j, after:=Cells(7, 17), LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows).Row
            MyResult = MyResult & "Rank " & k & " is " & j & " in row " & rowcount & vbCr
        End If
Next k

MsgBox MyResult
End Sub

The values in the range are not in ascending/descending order and there will always be duplicates. The Large function does find all the top 10 values, including duplicates, but it is just the row function that needs tweaking.

For reference I will be using the row number to lookup the corresponding ID number to the top 10 value in another column and plot it on a heat map. The message box is just a little test to see if the values are being picked up correctly.

Many thanks!!!

 

[venkat1926]

the data is lilke this 1 to 20 randomly placed in cells in collumn A

Excel Workbook
	A
1	hdng1
2	14
3	6
4	9
5	5
6	3
7	1
8	2
9	16
10	10
11	18
12	17
13	19
14	15
15	12
16	8
17	7
18	4
19	11
20	20
21	13
Sheet1

run this macro FOR THIS DATA and see column D and E. CONFIRM YOU GOT WHAT YOU WANT. MODIFY MCRO FOR YOUR DATA.

Sub test()
Dim r As Range, rrow(1 To 10), i As Integer, mmax(1 To 10)
Range("D1:E1").EntireColumn.Delete
Set r = Range(Range("A2"), Range("A2").End(xlDown))
For i = 1 To 10
mmax(i) = WorksheetFunction.Large(r, i)
'MsgBox mmax(i)
rrow(i) = WorksheetFunction.Match(mmax(i), r, 0)
'MsgBox rrow(i)
Cells(i + 1, "D") = mmax(i)
Cells(i + 1, "E") = rrow(i) + 1


Cells(1, "D") = "laragenumbrs"
Cells(1, "E") = "corrspnding row"
Next i
End Sub

 

[Mann750]

Hello again,

I've been searching for an answer to the above problem and I have come across the 'FindNext' function. I have managed to change my code to incorporate this and it IS working but I would like the concatenated results to be split and assigned to the correct ranked value. My code is below:

Sub Max10v2()
Dim rngTestArea As Range, rowcount As Range, rowcount1 As Range
Dim k As Integer, j As Long, lastrow As Long
Dim ExitLoop As Boolean
Dim FoundAt As String, MyResult As String
Dim report As Worksheet, register As Worksheet

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

Set report = Worksheets("REPORT")
Set register = Worksheets("Register")
lastrow = register.Cells(Rows.Count, 17).End(xlUp).Row
Set rngTestArea = register.Range("Q2:Q" & lastrow)
j = 0
For k = 1 To 10
    j = Application.WorksheetFunction.Large(rngTestArea, k)
        If j > 0 Then
            Set rowcount = rngTestArea.Find(what:=j, after:=Cells(7, 17).Offset(1), LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows)
                If Not rowcount Is Nothing Then
                    Set rowcount1 = rowcount
                    FoundAt = rowcount.Address
                    Do While ExitLoop = False
                        Set rowcount = rngTestArea.FindNext(after:=rowcount)
                        If Not rowcount Is Nothing Then
                            If rowcount.Address = rowcount1.Address Then Exit Do
                            FoundAt = FoundAt & ", " & rowcount.Address
                        Else
                            ExitLoop = True
                        End If
                    Loop
                End If
                    
            MyResult = MyResult & "Rank " & k & " is " & j & " in " & FoundAt & vbCr
        End If
Next k
MsgBox MyResult
End Sub

Currently my result in the message box looks like the following:

Rank 1 is 35 in $Q$7
Rank 2 is 32 in $Q$12, $Q$35
Rank 3 is 32 in $Q$12, $Q$35
Rank 4 is 29 in $Q$17, $Q$33, $Q$40
Rank 5 is 29 in $Q$17, $Q$33, $Q$40
Rank 6 is 29 in $Q$17, $Q$33, $Q$40
Rank 7 is 28 in $Q$13
Rank 8 is 27 in $Q$15
Rank 9 is 26 in $Q$36
Rank 10 is 23 in $Q$20

What I would ideally like is:

Rank 1 is 35 in $Q$7
Rank 2 is 32 in $Q$12
Rank 3 is 32 in $Q$35
Rank 4 is 29 in $Q$17
Rank 5 is 29 in $Q$33
Rank 6 is 29 in $Q$40
Rank 7 is 28 in $Q$13
Rank 8 is 27 in $Q$15
Rank 9 is 26 in $Q$36
Rank 10 is 23 in $Q$20

How would I go about only showing the address as linked to the ranked value and not the actual value?
I would really appreciate any help on this!!!

 

[Mann750]

Many thanks for your help venkat1926! Your macro works fine but ideally I need to adjust it so that outcome in columns 'D' and 'E' are not shown but are used for other calculations. I need to be able to extract a looked up value using the rank and row numbers and use them in another worksheet without having to introduce them to the worksheet, i.e. it all needs to be done 'behind the scenes' and the outcome in a messagebox, for example. How would modify the last part of your macro to do this?

 

[venkat1926]

It is not clar what exactly you want to dol

there are more than one way of solving the problem. yours is one way. mine is one. in my macro, mmax(1 to 10) and rrow(1 to 10) are numbers. so yoou can manipulate them. you can even copy these, instead of col D adn E in sheet 1, in another sheet and manipulate.

 

[Mann750]

Hi venkat1926, I have looked into your macro again and it seems that if I have duplicate values in the rank (or mmax) then the corresponding rrow is not found, just the first match. This is where my issue really lies...how can I get the macro to match the correct rrow to the mmax when there are duplicates? Again my results using your macro results in the following:

Rank 1 is 35 in row 7
Rank 2 is 32 in row 12
Rank 3 is 32 in row 12
Rank 4 is 29 in row 17
Rank 5 is 29 in row 17
Rank 6 is 29 in row 17
Rank 7 is 28 in row 13
Rank 8 is 27 in row 15
Rank 9 is 26 in row 36
Rank 10 is 23 in row 20

 

[venkat1926]

see this webpage

Ranking

<tbody>
</tbody>

 

[Mann750]

I'm sorry venkat1926 but the link you provided does not answer my query. Your macro works fine for ranking the numbers correctly but all I need is to somehow modify the Match function so that the result is not the first cell found but the actual corresponding cell to the ranked score. In the code I posted above, the message box shows all the correct cell references but I would like it to show the correct reference to the corresponding score. How would I manipulate the code to do this instead of concatenating all the results together?

                If Not rowcount Is Nothing Then
                    Set rowcount1 = rowcount
                    FoundAt = rowcount.Address
                    Do While ExitLoop = False
                        Set rowcount = rngTestArea.FindNext(after:=rowcount)
                        If Not rowcount Is Nothing Then
                            If rowcount.Address = rowcount1.Address Then Exit Do
[COLOR=#ff0000]                            FoundAt = FoundAt & ", " & rowcount.Address
[/COLOR]                        Else
                            ExitLoop = True
                        End If
                    Loop
                End If

I think the line in red needs to be amended but not sure...please someone help!