Verileri Siralama

[boss2090]

Merhaba Üstadlar,

Elde ettigim verileri sirlamak ve sirlama yapilirken büyükten kücüge dogru ve ayni olanlari birkere ve sahip oldugu adet sayisini toplayarak yapmak..

Örnek olarak bir dosya ekliyorum kisaca burda da aciklayayim.

1 Tane 2490 mm
3 Tane 2490 mm
1 Tane 5670 mm
5 Tane 6223 mm
3 Tane 1200 mm

Sonuc:

5 Tane 6223 mm
1 Tane 5670 mm
4 Tane 2490 mm
3 Tane 1200 mm

böyle olmali.

 

[Orion1]

Dosyanız ektedir.

Sub adet59()
Dim z As Object, list(), i As Long, son As Long
Range("D:E").ClearContents
Set z = CreateObject("scripting.dictionary")
list = Range("A2:B" & Cells(Rows.Count, "A").End(xlUp).Row).Value
son = UBound(list)
For i = 1 To son
    If Not z.exists(list(i, 2)) Then
        z.Add list(i, 2), list(i, 1)
        Else
        z.Item(list(i, 2)) = z.Item(list(i, 2)) + list(i, 1)
    End If
Next i
Erase list
Application.ScreenUpdating = False
Range("D1").Resize(z.Count, 2) = Application.Transpose(Array(z.items, z.keys))
Range("D1:E" & z.Count).Sort Range("E1"), xlDescending
Set z = Nothing
Application.ScreenUpdating = True
MsgBox "İşlem tamamdır." & vbLf & "evrengizlen@hotmail.com", _
        vbOKOnly + vbInformation, Application.UserName


End Sub

 

[boss2090]

Veri Siralama

Kardes cok tesekkürler...Ama boyutlarda yada adet sayisilarinda degisiklik vede eklemeler oldugunda otamatik yenilimiyor.
Eger Buttonsuz otomatik yenileme olursa mühetesem olur.

 

[turist]

Ekli dosyayı deneyiniz.