Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim n&, Place&, eRow&
Dim strPlace$
Dim ArryRank()
Dim ws2 As Worksheet, ws3 As Worksheet, ws4 As Worksheet
Set ws2 = ActiveWorkbook.Sheets("Sheet2")
Set ws3 = ActiveWorkbook.Sheets("Sheet3")
Set ws4 = ActiveWorkbook.Sheets("Sheet4")
If Not Intersect(Target, Union(Range("B6", "B44"), Range("C6", "C44"), Range("D6", "D44"))) Is Nothing Then
Application.EnableEvents = False
Select Case Target.Column
Case 2
ws2.Range("B1", "D1").Copy Range("B3")
eRow = Cells(Rows.Count, "B").End(xlUp).Row
ArryRank = Application.WorksheetFunction.Transpose(Range("B6", "B" & eRow))
ReDim Preserve ArryRank(1 To UBound(ArryRank) + 1)
ArryRank(UBound(ArryRank)) = Range("E4")
Case 3
ws3.Range("B1", "D1").Copy Range("B3")
eRow = Cells(Rows.Count, "C").End(xlUp).Row
ArryRank = Application.WorksheetFunction.Transpose(Range("C6", "C" & eRow))
ReDim Preserve ArryRank(1 To UBound(ArryRank) + 1)
ArryRank(UBound(ArryRank)) = Range("E4")
Case 4
ws4.Range("B1", "D1").Copy Range("B3")
eRow = Cells(Rows.Count, "D").End(xlUp).Row
ReDim ArryRank(1 To eRow - 4)
ArryRank = Application.WorksheetFunction.Transpose(Range("D6", "D" & eRow))
ReDim Preserve ArryRank(1 To UBound(ArryRank) + 1)
ArryRank(UBound(ArryRank)) = Range("E4")
End Select
Call QuickSortRank(ArryRank, LBound(ArryRank), UBound(ArryRank))
Place = Application.WorksheetFunction.Match(Range("E4"), ArryRank, 0)
Select Case Place
Case 1
Range("F4") = "1st"
Case 2
Range("F4") = "2nd"
Case 3
Range("F4") = "3rd"
Case Else
Range("F4") = Place & "th"
End Select
Application.EnableEvents = True
End If
End Sub
Private Sub QuickSortRank(arr() As Variant, inLow As Long, inHi As Long)
Dim pivot&, tmpSwap&, tmpLow&, tmpHi&
tmpLow = inLow
tmpHi = inHi
pivot = arr((inLow + inHi) \ 2)
Do While (tmpLow <= tmpHi)
Do While arr(tmpLow) > pivot And tmpLow < inHi 'decending
tmpLow = tmpLow + 1
Loop
Do While pivot > arr(tmpHi) And tmpHi > inLow 'decending
tmpHi = tmpHi - 1
Loop
If tmpLow <= tmpHi Then
tmpSwap = arr(tmpLow)
arr(tmpLow) = arr(tmpHi)
arr(tmpHi) = tmpSwap
tmpLow = tmpLow + 1
tmpHi = tmpHi - 1
End If
Loop
If inLow < tmpHi Then QuickSortRank arr, inLow, tmpHi
If tmpLow < inHi Then QuickSortRank arr, tmpLow, inHi
End Sub