Küçükten Büyüğe Sıralama Hatası

[beyinmuhendisi]

Aşağıdaki kod ile otomatik sıralama yaparken sıralama hatası alıyorum.
Durum-------Olması Gereken
707------------701 D
708------------702 S
709 -------------...
701 D----------707
702 S-----------708
... -------------- ...

Sub Listele()
Application.ScreenUpdating = False
Application.EnableEvents = False
ActiveSheet.Unprotect ""
Range("Kurs").Value = ""
Dim i As Long
Dim sayac As Long

sayac = 6

For i = 1 To [H65536].End(xlUp).Row
If WorksheetFunction.CountIf(Range("H1:H" & i), Range("H" & i)) = 1 Then
Range("J" & sayac) = Range("H" & i)
sayac = sayac + 1
End If
Next
Range("J7:J60").Sort [J7], Order1:=xlAscending
Application.EnableEvents = True
Application.ScreenUpdating = True
ActiveSheet.Protect ""
End Sub

Teşekkürler!

 

[vardar07]

"I"Sütunu yardımcı olarak kullanılmıştır.Sizdekinle değiştirip denermisiniz.

Sub Listele()
Application.ScreenUpdating = False
Application.EnableEvents = False
ActiveSheet.Unprotect ""
Range("Kurs").Value = ""
Dim i As Long
Dim sayac As Long
sayac = 6
For i = 1 To [H65536].End(xlUp).Row
    If WorksheetFunction.CountIf(Range("H1:H" & i), Range("H" & i)) = 1 Then
        Range("J" & sayac) = Range("H" & i)
    sayac = sayac + 1
   Range("I7:I" & sayac).FormulaR1C1 = "=LEFT(RC[1],3)"
    Cells(sayac, "I").Value = Cells(sayac, "I").Value
    End If
Next
Range("I7:J60").Sort [I7], Order1:=xlAscending
Range("I7:I60").ClearContents
Application.EnableEvents = True
Application.ScreenUpdating = True
ActiveSheet.Protect ""
End Sub

 

[beyinmuhendisi]

Sayın vardar07 kod çalıştı. Teşekkür ederim!
İlginç bir ayrıntı. Aklınıza, gönlünüze sağlık.

 

[vardar07]

Rica ederim. Normal sıralamada önce sayılar sonrada harf kriter oluyor. Sizin olayda bundan başka çözüm olacağını zannetmiyorum. Kolay gelsin