­ã´£³¡ªL

Sub «ö¥X²{¦¸¼Æ±Æ§Ç()
Dim Arr, A, xD, Brr(1 To 20000, 1 To 2), N&
Range("A15:B30").Clear
Arr = Range("A2:H6")
Set xD = CreateObject("Scripting.Dictionary")
For Each A In Arr
    If A = "" Then GoTo 101
    xD(A) = xD(A) + 1
    If xD(A) = 2 Then N = N + 1:  xD(A & "S") = N:  Brr(N, 1) = A
    If xD(A) > 1 Then Brr(xD(A & "S"), 2) = xD(A)
101: Next
With [A15:B15].Resize(N)
     .Value = Brr
     .Sort Key1:=.Item(2), Order1:=xlDescending, _
           Key2:=.Item(1), Order2:=xlDescending, Header:=xlNo
End With
End Sub


==========================================

­ã´£³¡ªL

¦^´_ 3# s13030029

   IF N=0 THEN EXIT SUB '¥[³o¤@¦æ
   With [A15:B15].Resize(N)
     .Value = Brr
     .Sort Key1:=.Item(2), Order1:=xlDescending, _
           Key2:=.Item(1), Order2:=xlDescending, Header:=xlNo
   End With