macro to find ranks BUG empty cell

[sl1990]

Hi ive got this macro (below) that i want to run to find the best score over lots of events.

at the moment its only for one row of the sheet but i want to run it on multiple rows is there a way i can do this without having to copy out the same macro
20 times and change the the range?

I also want to run the macro on 150 sheets how would i loop it through these?

Some of the sheets have more rows data than others so how would i write an IF saying is the is data in the A cell above the row. (so if cell A1 has data then macro on B2:R2)

the last thing is that if there is an empty cell in the range it ranks that cell as being a high score. is there any way that if it finds an empty cell it can return the words "EMPTY" in the results or run another macro befor to find any empty cells in the ranges for the workbook?

heres the macro ive writen so far

Sub SportsRank_1()

Range("X3").Value = "Place"
Range("Y3").Value = "Name(s)"
Range("X4").Value = "1st"
Range("Y4:Y100").Value = ""
On Error Resume Next
For Each cell In Range("B4:R4")
cell.Offset(1, 0).Value = Application.Rank(cell.Value, Range("B4:R4"), 0)
Next
For i = 1 To 10
For Each cell In Range("B5:R5")
If cell.Value = i Then
setPlace = setPlace & cell.Offset(-2, 0).Value & ", "
End If
Next cell
Range("Y" & Rows.Count).End(xlUp).Offset(1, 0).Value = Left(setPlace, Len(setPlace) - 2)
setPlace = ""
Next i
Range("B5:R5").ClearContents
Range("Y5:Y100").ClearContents

End Sub

heres an googledocs example of the type of data i want to run the macro on

https://spreadsheets.google.com/spr...hvdEFCTW9jd1hOYzZ1cjdwUEZ1TXZMS1E&output=html

any help will be amazing ive been pulling my hair out over this for weeks !

cheers
Sam

 

[Jerry Sullivan]

...any help will be amazing ive been pulling my hair out over this for weeks !

Hi Sam,

The code below should take care of the ranking, blanks, and variable number of rows.

Give this a try and see how it works on one sheet.

I think you'll be able to add back in the other parts about setplace
and headers without losing any more hair.

Option Explicit
 
Sub SportsRank_1()
    Dim c As Range
    Dim i As Long
    Application.ScreenUpdating = False
    Dim ws As Worksheet
    Set ws = ActiveSheet
    With ws.Cells
        For Each c In .Range(.Range("A2"), _
                .Range("A" & .Rows.Count).End(xlUp))
            If c.Value <> "" Then   'sport line found
                With c.Offset(2, 1).Resize(1, 17)
                    .FormulaR1C1 = _
                     "=IFERROR(RANK(R[-1]C,R[-1]C2:R[-1]C18" _
                        & ",0),""EMPTY"")"
                End With
            End If
        Next c
    End With
    Set ws = Nothing
    Set c = Nothing
End Sub

Once you have that working, I'll be glad to help you with the last piece
of stepping through each sheet in your workbook.