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

[yasinkaratas0359]

Merhabalar;

Sıralama 10'lu Şekilde Başlamasını İstiyorum Fakat A'dan Z'ye Sıralama Aşağıdaki Gibi Çıkıyor.

Yardımlarınız İçin Şimdiden Teşekkürler; Saygılar

100X108X8/9

100x112,2x7,1

100X115X12,3

10X16X3,6X4,8

 

[Necdet]

Merhaba,

Verileriniz rakam olmadığı için istediğiniz sıralama olmaz. Eğer illaki sıralamak istiyorsanız metni sütunlara ayırıp (X ler dikkate alınarak) sıralama yapıldıktan sonra tekrar birleştirmek ile olabilir.

Aşağıdaki kodları bir modüle kopyalayıp deneyiniz.

Sub Sirala()

    Dim Rng As Range
    Dim BsRow As Long
    Dim BtRow As Long
    Dim BtRow2 As Long
    Dim BsCol As Integer
    Dim BtCol As Integer
    Dim SonCol As Integer
    Dim Sh As Worksheet
    Dim i As Long
    Dim j As Integer
    Dim txt As Variant
    Dim tx As String
    Set Sh = ActiveSheet
    
    On Error Resume Next
    
    Set Rng = Application.InputBox( _
      Title:="Başlangıç Hücreyi Seçiniz", _
      Prompt:="Hücre Seçimi", _
      Type:=8)
      
    On Error GoTo 0
 
    If Rng Is Nothing Then
        MsgBox "Seçim Yapmadınız....", vbInformation
        Exit Sub
    End If
    
    BsRow = Rng(1, 1).Row
    BtRow = Rng(1, 1).End(xlDown).Row
    BsCol = Rng(1, 1).Column
    
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
    End With
    
    Sheets.Add After:=Sheets(Sheets.Count)
    Sh.Range(Sh.Cells(BsRow, BsCol), Sh.Cells(BtRow, BsCol)).Copy Range("A1")
    For i = 1 To Cells(Rows.Count, "A").End(3).Row
        Cells(i, "A") = Trim(Replace(Cells(i, "A"), "x", "X"))
        txt = Split(Trim(Replace(Cells(i, "A"), "x", "X")), "X")
        For j = 0 To UBound(txt)
            Cells(i, j + 2) = CDbl(txt(j))
        Next j
    Next i
    
    SonCol = Cells.Find("*", , , , xlByColumns, xlPrevious).Column
    i = i - 1
    Range(Cells(1, 2), Cells(i, SonCol)).Sort Key1:=Range("B1"), Key2:=Range("C1")
    
    BtRow2 = i
    For i = 1 To BtRow2
        tx = Cells(i, "B")
        For j = 3 To SonCol
            If Not Cells(i, j) = "" Then tx = tx & "X" & Cells(i, j)
        Next j
        Cells(i, "A") = tx
    Next i
    
    Range("A1:A" & BtRow2).Copy Sh.Cells(BsRow, BsCol)
    ActiveSheet.Delete
    Sh.Select
End Sub

 

[Ömer]

Merhaba,

Veriler A sütunudaysa B sütunu yardımıyla kod ile sıralayabilirsiniz.

Sub test()

    Dim son As Integer, veri(), d As Object, i As Integer, deg
    
    son = Cells(Rows.Count, "A").End(xlUp).Row
    
    Application.ScreenUpdating = False
    Range("B1") = "xxx"
    
    For i = 2 To son
        If Cells(i, "A") <> "" Then
            Cells(i, "B") = Evaluate(Replace(Replace(Replace( _
                UCase(Cells(i, "A")), "X", "*"), ".", ""), ",", "."))
        End If
    Next i
    
    'büyükten küçüğe için xlAscending yerine xlDescending yazarsınız
    Range("A2:B" & son).Sort Range("B2"), xlAscending
    Range("B:B") = ""
    
    Application.ScreenUpdating = True
    
End Sub