Sub RankHighest()
Dim i, Rank ', Count
Dim Rng As String
Rng = "B2:B12"
For i = 2 To 12
'Find rank for cell value
Rank = WorksheetFunction.Rank(ActiveSheet.Cells(i, 2), ActiveSheet.Range(Rng))
'Check which departments ranked 1 to 3 are highlighted
If ActiveSheet.Cells(i, 1).Interior.ColorIndex <> -4142 And Rank <= 3 Then
MsgBox ActiveSheet.Cells(i, 1) & " is Ranked " & Rank & " and it is highlighted!"
End If
'Check which departments ranked 1 to 3 are NOT highlighted
If ActiveSheet.Cells(i, 1).Interior.ColorIndex = -4142 And Rank <= 3 Then
MsgBox ActiveSheet.Cells(i, 1) & " is Ranked " & Rank & " and it is NOT highlighted!"
End If
Next i

End Sub


Sub RankLowest()
Dim i, Rank, Count
Dim Rng As String
Rng = "B2:B12"
For i = 2 To 12
'Find rank for cell value
Rank = WorksheetFunction.Rank(ActiveSheet.Cells(i, 2), ActiveSheet.Range(Rng))
'Find how many departments are in range
Count = WorksheetFunction.Count(ActiveSheet.Range(Rng))
'Check if last 3 departments  are highlighted
If ActiveSheet.Cells(i, 1).Interior.ColorIndex <> -4142 And Rank >= Count - 2 Then
MsgBox ActiveSheet.Cells(i, 1) & " is Ranked " & Rank & " from " & Count & " and it is highlighted!"
End If
'Check if last 3 departments  are  NOT highlighted
If ActiveSheet.Cells(i, 1).Interior.ColorIndex = -4142 And Rank >= Count - 2 Then
MsgBox ActiveSheet.Cells(i, 1) & " is Ranked " & Rank & " from " & Count & " and it is NOT highlighted!"
End If
Next i

End Sub