Karışık sayıları sıralama

[teknoman]

Ekteki gibi çok fazla karışık sayılardan oluşan bir tablomuz var.
Bu sayıları soldan sağa ve satır satır sıralayabilirmiyiz...

 

[halit3]

Makro ile sıralama kodu aşağıdadır.

not: dosyanıza bir adet userform ekleyin eklediğiniz userforma da bir adet ListView nesnesi ekleyin

örnek kodda userformun adı (UserForm1) ListView nesnesinin adıda (ListView1 ) olmalı

Sub sırala()


Dim x, j, s, i
Set j = CreateObject("Scripting.Dictionary")


Range("K4:Q18").ClearContents

Application.ScreenUpdating = False

UserForm1.ListView1.ListItems.Clear
UserForm1.ListView1.ColumnHeaders.Clear
UserForm1.ListView1.View = lvwReport
UserForm1.ListView1.Gridlines = True
UserForm1.ListView1.FullRowSelect = True
UserForm1.ListView1.ColumnHeaders.Add , , "BENZERSİZLER", 200

For Each x In Range("c4:ı18")
If x.Value <> "" Then
If IsNumeric(x.Value) = True Then
If Not j.exists(x.Value) Then
j.Add x.Value, Nothing
UserForm1.ListView1.ListItems.Add , , Format(x.Value, "000000000000000")

End If
End If
End If
Next x

UserForm1.ListView1.Sorted = True
UserForm1.ListView1.SortKey = 0
UserForm1.ListView1.SortOrder = lvwAscending
UserForm1.ListView1.Sorted = False


basla1 = Timer
bekle1 = 1
While Timer < basla1 + bekle1
DoEvents
Wend


Set Sh = Sheets(ActiveSheet.Name)
yer = ActiveSheet.Name
sat1 = 4
n = 10
For r = 1 To UserForm1.ListView1.ListItems.Count
n = n + 1
Sheets(yer).Cells(sat1, n).Value = UserForm1.ListView1.ListItems(r).Text * 1
If n = 17 Then n = 10: sat1 = sat1 + 1
Next r


MsgBox "işlem tamam"
Application.ScreenUpdating = True


End Sub

 

[teknoman]

Hocam çok teşekkür ederim.Elleriniz dert görmesin.