İl ve İlçe Sıralaması

[wezyr]

örnek dosyamda il sıralamasını aldırabiliyorum fakat okulun ilçe sırasını nasıl formülüze edebilirim. verilerin yerleri değişse bile okulun belirtilen puan türüne il ve ilçe sırası puan sırasını nasıl aldırabilirim. bazı puanlar aynı olabilir.

 

[wezyr]

ilçe sıralaması için forumdan aşağıdaki dizi formülü buldum ama buda sistemi kasmakta ayrıca - değerlerde yok hatası vermekte normal bir formülle yapabilirmiyim
{=KAÇINCI(F4;BÜYÜK(($A$4:$A$300=A4)*$F$4:$F$300;SATIR(DOLAYLI("1:100")));0)}

 

[wezyr]

Sanırım çözüm yok... yada ben anlatamadım...

 

[hlojan]

Doğru anladıysam ilçelere göre ve puanlara göre sıralama yapmak istiyorsunuz.

Formüle gerek yok onun için. Tablonuzu biçimlendirdim

 

[wezyr]

hocam maalesef... süzgeçle sıralamak istemiyorum burda özrnek olarak az veri yükledim bunun formatında 15 sayfam var ve veri olarak satır olarak baya bir verim var 6 puan türü var...

 

[wezyr]

Yardım Lütfen

soruma cevap alamadığım için örnek dosyamı değiştirerek tekrar yolluyorum. il ve ilçe sıralarımı ders netlerine ve toplam nete göre aldırmam gerekiyor. yardımcı olabilirseniz çok sevinirim...

 

[veyselemre]

VBA ile çözüm.

Örnek Dosya

İlgili sayfanın kod sayfasına eklenecek kodlar.
(Sütun başlıkkarına çift tıklanınca sıralama yapar.)

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Cancel = True
    If Target.Row <> 2 Then Exit Sub
    If Target.Column > 33 Then Exit Sub
    son = Range("a" & Rows.Count).End(3).Row
   
    Select Case Target.Column
    Case 1, 2, 5, 8, 11, 14, 17, 20, 23, 26, 29, 32
        Range("A2:AF" & son).Sort Key1:=Target.Offset(0), Order1:=xlAscending, Header:=xlGuess
    Case 3, 6, 9, 12, 15, 18, 21, 24, 27, 30
        Range("A2:AF" & son).Sort Key1:=Target.Offset(0, 2), Order1:=xlDescending, Header:=xlGuess
    Case 4, 7, 10, 13, 16, 19, 22, 25, 28, 31
     Range("A2:AF" & son).Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Target.Offset(0, 1), Order2:=xlDescending, Header:=xlGuess
    End Select
End Sub

Modül içerisine eklenecek kodlar.

Sub temizle()
    son = Range("a" & Rows.Count).End(3).Row

    For sut = 3 To 30 Step 3
        Cells(3, sut).Resize(son - 2, 2).ClearContents
    Next sut
End Sub

Sub siralamaBul()
    Application.ScreenUpdating = False
    son = Range("a" & Rows.Count).End(3).Row

    ReDim sira(1 To son - 2)

    For i = 1 To son - 2
        sira(i) = i + 2
    Next i

    For sut = 5 To 32 Step 3
        al = Application.Transpose((Cells(3, sut).Resize(son - 2).Value))
        myarr = Application.Transpose(Array(al, sira))
        Call sirala(myarr)

        For i = 1 To son - 2
            Cells(myarr(i, 2), sut - 2) = i
        Next i
    Next sut

    With CreateObject("scripting.dictionary")
        Dim w(1 To 2, 1 To 1)
        Dim n
        For sut = 5 To 32 Step 3
            For i = 1 To son - 2
                ilce = Cells(i + 2, 1)
                If Not .exists(ilce) Then
                    w(1, 1) = Cells(i + 2, sut)
                    w(2, 1) = i + 2
                    .Add ilce, w
                Else
                    n = .Item(ilce)
                    ind = UBound(n, 2) + 1
                    ReDim Preserve n(1 To 2, 1 To ind)
                    ind = UBound(n, 2)
                    n(1, ind) = Cells(i + 2, sut)
                    n(2, ind) = i + 2
                    .Item(ilce) = n
                End If
            Next i
            For Each ilce In .keys
                myarr = .Item(ilce)

                If UBound(myarr, 2) > 1 Then
                    myarr = Application.Transpose(myarr)
                    Call sirala(myarr)
                    For i = 1 To UBound(myarr)
                        Cells(myarr(i, 2), sut - 1) = i
                    Next i
                Else
                    Cells(myarr(2, 1), sut - 1) = 1
                End If
            Next
            .RemoveAll
        Next sut
    End With
    Application.ScreenUpdating = True
End Sub
Sub sirala(liste)
    a = UBound(liste)
    For i = 1 To a - 1
        For ii = i + 1 To a
            If liste(i, 1) < liste(ii, 1) Then
                temp = liste(i, 1)
                liste(i, 1) = liste(ii, 1)
                liste(ii, 1) = temp

                temp = liste(i, 2)
                liste(i, 2) = liste(ii, 2)
                liste(ii, 2) = temp
            ElseIf liste(i, 1) = liste(ii, 1) Then
                liste(i, 1) = liste(ii, 1)

                If liste(i, 2) > liste(ii, 2) Then
                    temp = liste(i, 1)
                    liste(i, 1) = liste(ii, 1)
                    liste(ii, 1) = temp

                    temp = liste(i, 2)
                    liste(i, 2) = liste(ii, 2)
                    liste(ii, 2) = temp
                End If

            End If
        Next ii
    Next i
End Sub

 

[wezyr]

teşekkürler elinize sağlık... formülle çözme şansımız yokmu

 

[veyselemre]

Ben formül işinden anlamam.