sıralama

[umitumit]

arama yaptım ama sorunuma çözüm bulamadım.

a sütunundaki renk isimlerini b sütunundaki verilerin toplamına göre büyükten küçüğe doğru sıralamak istiyorum

şimdiden teşekkürler

 

[Necdet]

Sayın umitumit,


Ekteki dosyayı inceleyiniz. ÖZET TABLO (PİVOT TABLE) ile yapılmıştır.

Özet tablo ile bilgileri Excel Dersanesinde bulabilirsiniz.

 

[veyselemre]

Sub Dene()
    [H:I].ClearContents
    son = [a2].End(xlDown).Row
    Range("a2:b2").Copy [h2]
    Range("a2:a" & son).AdvancedFilter xlFilterCopy, , [h2], True
    son2 = [h2].End(xlDown).Row
    With Range("I3:I" & son2)
        .FormulaR1C1 = "=SUMIF(R3C1:R" & son & "C1,RC[-1],R3C2:R" & son & "C2)"
        .Value = .Value
    End With
    Range("H3:I" & son2).Sort Key1:=Range("I3"), Order1:=xlDescending, Header:=xlGuess
End Sub

 

[umitumit]

necdet yesertener'e;

1-listede değişiklik yapınca özet tablom değişmedi
2-ben ilk 10 veriyi istedim ama özet tablo hepsini getiriyor

veyselemre'ye;
yazdığın macro nun olduğu dosyayı ekleyip gönderirsen daha iyi anlarım sanırım.
çünkü ben çalıştıramadım

tekrar teşekkürler

 

[Necdet]

umitumit'e

Ültimatom gibi yazmışsınız beaaa

1. listede değişiklik yapınca bilgiler değişir (bilmek gerek, bilmiyorsanız sormak gerek)
2. İlk kaç veriyi isterseniz isteyiniz Özet tablo bunu size verir (bilmek gerek, bilmiyorsanız sormak gerek)

 

[nsertoglu]

örnek dosyanızdaki ilk boş satırı silin ve aşağıdaki kodları yaratacağınız bir makronun içine kopyalayıp f8-adımlayarak çalıştırın ve çalışma aşamalarını izleyin.. Kolay gelsin.

Sub topla_sirala()
'Application.ScreenUpdating = True
Columns("C:H").Select
Selection.ClearContents
Cells(1, 1).Select
GoSub topla:
GoSub sirala:
'Application.ScreenUpdating = True 'sayfa değişimi gizleme iptali
'yaratılan geçici veri silinecek
Columns("D:E").Select
Selection.ClearContents
[f2].Select
End
topla:
Sheets("sayfa1").Select
sutnts = 256 - WorksheetFunction.CountBlank(Range("A1:IV1"))
ssayts = 65536 - WorksheetFunction.CountBlank(Range("a1:a65536"))

'sayfa daki bilgiler 2 kolon sağa kopyalandı ve renk sıralaması yapıldı
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Range("D1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Sort Key1:=Range("D2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("D2").Select
rnk_aynı = 0

For cy = 2 To ssayts
Cells(cy, 4).Select
rnk = Cells(cy, 4)
rnk_onc = Cells(cy - 1, 4)
If rnk_onc <> "renk" And rnk_onc <> rnk Then ilk_str = cy
If Cells(cy + 1, 4) = rnk Then
rnk_ayn&#305; = 1 'bir sonraki sat&#305;rdaki renk farkl&#305;
son_str = cy
Else
'ilk_str = cy
son_str = cy
If ilk_str <> Empty And ilk_str <> son_str Then
For i = ilk_str To son_str
rnk_top = Cells(i, 5) + rnk_top
Next i
Cells(cy, 7) = rnk_top
Else
rnk_ayn&#305; = 0 'bir sonraki sat&#305;rdaki renk farkl&#305;
Cells(cy, 7) = Cells(cy, 5)
End If
Cells(cy, 6) = rnk
rnk_top = 0
End If
Next cy
Return

sirala:
rw1 = 2
rng1 = "F" + LTrim(Str(rw1))
rng2 = "G" + LTrim(Str(ssayts))
rng3 = rng1 + ":" + rng2
rng4 = "G" + LTrim(Str(rw1)) 's&#305;ralama kolonu
Range(rng3).Select
' s&#305;ralama 1..
Selection.Sort Key1:=Range(rng4), Order1:=xlDescending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
' s&#305;ralama 2..
Range(rng3).Select
Selection.Sort Key1:=Range(rng4), Order1:=xlDescending, Key2:=Range("F2") _
, Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2 _
:=xlSortNormal
' SIRALAMA B&#304;TT&#304;
Return
End Sub

 

[nsertoglu]

benim ve veyselemre nin makroları eklenmiş dosya versiyonu..

 

[Recep İpek]

Alternatif olarak aşağıdaki kodlarıda kullnabilirsiniz.

Sub Aktar()
Dim a, i, s As Long, b()
Set s1 = Sheets("Sayfa1")
Application.ScreenUpdating = False
a = s1.Range("a3:b" & s1.[a65536].End(xlUp).Row).Value
ReDim b(1 To UBound(a, 1), 1 To 3)
With CreateObject("Scripting.Dictionary")
    .CompareMode = vbTextCompare
        For i = 1 To UBound(a, 1)
            If Not .exists(a(i, 1)) Then
                s = s + 1
                .Add (a(i, 1)), s
                b(s, 1) = s
                b(s, 2) = a(i, 1)
            End If
                b(.Item(a(i, 1)), 3) = b(.Item(a(i, 1)), 3) + a(i, 2)
        Next
End With
With s1.Range("f2")
    .Resize(, 3).ClearContents
    .Resize(s, 3).Value = b
End With
Range("g2:h20").Sort Key1:=Range("h2"), Order1:=xlDescending, Header:=xlGuess
son = s1.[f65536].End(xlUp).Row
For k = 2 To son
    If s1.Cells(k, "f").Value > 10 Then
    s1.Range(s1.Cells(k, "f"), s1.Cells(k, "h")).ClearContents
    End If
Next k
Application.ScreenUpdating = True
MsgBox "Bitti"
[a1].Select
Set s1 = Nothing
End Sub

 

[umitumit]

haşaaaa.... ne haddime...?
üstadlara ültimatom kim? ben kim?

ripek arkadaşın mesajı işimi halledecek gibi.
nsertoglu ve veyselemre nin dosyaları üzerinde henüz çalışamadım.
macro konusunda biraz zayıfım. hatta biraz değil bayağı bi zayıfım.

uygulama olmayınca kitaplardan birşey anlamıyorum
yol gösteren olunca çok zevkli oluyor keşfetmek.

mesajıma cevap veren herkese teşekkür ederim.

ümit