Returns values based on one cell

[nkroberts]

On sheet 1 I have a drop down in cell A1 that lists 4 teams. On sheet 2 I have a list of athletes (column B) their team (Column A) and their score (Column C).

Depending on what is selected in cell A1 I want to list their top ten athletes (A2:A11) and their scores (B2:B11)

 

[ranman256]

alter the sheet names as you wish:

Sub TopSort()
Dim iRows As Long, iStart As Long, iLast As Long
Dim shtTarg As Worksheet
Dim sTeam


sTeam = Range("A1").Value


Sheets("Teams").Activate
    Range("A1").Select
    Cells.Find(What:=sTeam, After:=ActiveCell, LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False).Activate
    iStart = ActiveCell.Row
    While ActiveCell.Value = sTeam
        ActiveCell.Offset(1, 0).Select
    Wend
    iLast = ActiveCell.Row - 1
    iRows = iLast - iStart + 1
    
    Range("A" & iStart & ":C" & iLast).Select
    Selection.Copy
    Sheets.Add After:=ActiveSheet
    Set shtTarg = ActiveSheet
    
    ActiveSheet.Paste
    Application.CutCopyMode = False
    shtTarg.Sort.SortFields.Clear
    shtTarg.Sort.SortFields.Add Key:=Range("C1:C" & iRows), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With shtTarg.Sort
        .SetRange Range("A1:C" & iRows)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("A1").Select
    ActiveSheet.Name = sTeam
End Sub