Sıralama Problemi

[Muhammet Okumuş]

Arkadaşlar merhaba. Sütunda bulunan verileri başka sütunda birleştirip sıralamak istiyorum. En yüksek değerler eşit ise 2. değerlere göre sıralatmak istiyorum. 2. değerler de eşit ise 3. değerlere bakılacak. Ama bazı isme ait 1 değer varken bazılarında 1'den fazla değer olabiliyor.
Yardımlarınız için şimdiden teşekkür ediyorum. Formül çözümü istemiyorum. Sayı değerleri I sütununda , ile ayrılmış olmalı. Farklı sütunlarda olmayacak.( Görseldeki gibi)

 

[veyselemre]

Sub test()

    Dim veri, i, ii, kys, itms, tmp
    veri = Range("B6:C" & Cells(Rows.Count, 2).End(3).Row)
    For i = 1 To UBound(veri) - 1
        For ii = i + 1 To UBound(veri)
            If veri(ii, 2) > veri(i, 2) Then
                tmp = veri(ii, 1): veri(ii, 1) = veri(i, 1): veri(i, 1) = tmp
                tmp = veri(ii, 2): veri(ii, 2) = veri(i, 2): veri(i, 2) = tmp
            End If
        Next ii
    Next i

    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(veri)
            .Item(veri(i, 1)) = .Item(veri(i, 1)) & Format(veri(i, 2), "000")
        Next i
        kys = .keys
        itms = .items
    End With

    For i = 0 To UBound(itms) - 1
        For ii = i + 1 To UBound(itms)
            If itms(ii) > itms(i) Then
                tmp = kys(ii): kys(ii) = kys(i): kys(i) = tmp
                tmp = itms(ii): itms(ii) = itms(i): itms(i) = tmp
            End If
        Next ii
    Next i

    For i = 0 To UBound(itms)
        tmp = ""
        For ii = 1 To Len(itms(i)) Step 3
            tmp = tmp & " , " & Val(Mid(itms(i), ii, 3))
        Next ii
        Cells(i + 6, "J").Value = kys(i)
        Cells(i + 6, "K").Value = Mid(tmp, 4)
    Next i

End Sub

 

[Muhammet Okumuş]

Veysel Bey, sizin diziler konusundaki hakimiyetinize hayranım. Çok teşekkür ederim. Tek kelimeyle muazzam benim için.