ÖSYM Yerleştirme Algoritması

[halit3]

Bence kontenjan resmine göre dağılım böyle olmalı
6 ve 10 sıradakiler yerleşemez diğerleri renklerine göre yerleşti

 

[hgenc545]

Ta

Hocam diyelim ki Sayısalda ilk 40 öğrenci Hacettepe Tıp seçsin ve kontenjan da 40 kişi. Bu durumda 41 ile 10.000 kişi arasındaki öğrencilerin de ilk tercihi bu bölüm. O zaman bu kişiler açıkta mı kalacak. 41 ile 10.000 sıradakilerin ikinci Tercihi ÇAPA Tıp olsun. Ben de 10.001 sıradayım ve ilk tercihim ÇAPA Tıp. 41. Sıra atanamazken benim o bölüme atanmam ne kadar doğru olur.
Doğrusu puan üstünlüğüne göre atama olmalı. 41. Sıradakinin tüm tercihlerine bakılmadan 10.001 olan kişiyi yerleştirmek adil olmaz.

İşte o yüzden uzmanlar der ki doğru tercihler yapın, tercih sırası çok önemli diye her sınav sonrası uyarırlar...

 

[Muhammet Okumuş]

AD5 sayısal 3. sıra. AD9 ise 7. sıra. Bu durumda AD5 yerleşmelidir.

Bence kontenjan resmine göre dağılım böyle olmalı
6 ve 10 sıradakiler yerleşemez diğerleri renklerine göre yerleşti

Ekli dosyayı görüntüle 243414

 

[Muhammet Okumuş]

Ta



İşte o yüzden uzmanlar der ki doğru tercihler yapın, tercih sırası çok önemli diye her sınav sonrası uyarırlar...

Merkezi yerleştirme işleminde bir programa kesin kayıt hakkı kazananların belirlenmesinde, hangi sırada olursa olsun bu programa tercihleri arasında yer vermiş olan adaylardan, yerleştirmede kullanılan Y-ÖSS puanı ve varsa ek puan toplamı büyük olana öncelik tanınacaktır.

 

[Muhammet Okumuş]

Biraz sonuca ulaştım gibi.

 

[veyselemre]

Oldu gibi.

 

[Muhammet Okumuş]

Değişik formatta hazırlamışsınız. Anlamaya çalışıyorum.

 

[Muhammet Okumuş]

Veysel Bey, her bölüm için ayrı bir sütun mu açmak gerekiyor sanırım.

 

[Muhammet Okumuş]

Oldu gibi.

Böyle hata çıkıyor. Kontenjanlarda yapılan değişimlere göre bazen hata veriyor, bazen vermiyor.

 

[Muhammet Okumuş]

Sizin göndermiş olduğunuz dosyada da kontenjanları sırasıyla 2-2-2-3 yapınca aynı hatayı verdi.

 

[veyselemre]

Sizin göndermiş olduğunuz dosyada da kontenjanları sırasıyla 2-2-2-3 yapınca aynı hatayı verdi.

Yani hata verebilir; profesyonel bir çalışma değil yeterince veriyle test edilmedi, yukarıda verilen pdf deki tezde verilen ipuçları kullanılarak verilen örnek dağıtım aynı şekilde sonuçlandırıldığı için buraya ekledim.

Sizin sorunuza yönelik bir çalışma da aşağıdadır. Bu da sadece sizin verileriniz kullanılarak gerçekleştirildi.

Sub baslat()
    Dim sat, son, basliklar, i, ii, aday, tercih, sut, puan
    Range("M:R").Clear
    Range("A4:J13").Interior.Color = xlNone
    sat = 4
    son = Cells(Rows.Count, "E").End(3).Row
    basliklar = Array("PuanS", "Ter", "A.No", "TerSira", "Sat")
    Range("M3").Resize(, UBound(basliklar) + 1).Value = basliklar
    For i = 8 To 10
        For ii = 4 To son
            tercih = Cells(ii, i).Value
            aday = Cells(ii, 5).Value
            Select Case tercih
                Case "A", "B", "C"
                    sut = 1
                Case "D", "E", "F"
                    sut = 2
                Case "G", "H"
                    sut = 3
            End Select
            puan = Cells(ii, sut).Value
            Cells(sat, "M").Value = puan
            Cells(sat, "N").Value = tercih
            Cells(sat, "O").Value = aday
            Cells(sat, "P").Value = i
            Cells(sat, "Q").Value = ii
            sat = sat + 1
        Next ii
    Next i
    son = Cells(Rows.Count, "M").End(3).Row
    Range("M3:Q" & son).Sort [N3], , [M3], , , [P3], , xlYes
    yerlestir
End Sub
Sub yerlestir()
    Dim dic As Object, kontenjanlar, son, i, ii, aday, tercih, kalan, al, degisti, sat, sut, sira
    Set dic = CreateObject("Scripting.Dictionary")
    With Sheets("KONTENJAN")
        kontenjanlar = .Range("B2:C" & .Cells(Rows.Count, 2).End(3).Row).Value
    End With
    With dic
        For i = 1 To UBound(kontenjanlar)
            .Item(kontenjanlar(i, 1)) = kontenjanlar(i, 2)
        Next i
    End With

    son = Cells(Rows.Count, "M").End(3).Row

    For i = 4 To son
        tercih = Cells(i, "N").Value
        If Cells(i, "M").Interior.Color = vbYellow Then
            kalan = dic.Item(tercih)
            If kalan > 0 Then
                kalan = dic.Item(tercih)
                kalan = kalan - 1
                dic.Item(tercih) = kalan
            End If
        End If
    Next i

    For i = 4 To son
        If Cells(i, "M").Interior.Color = 16777215 Then
            tercih = Cells(i, "N").Value
            sat = Cells(4, "Q").Value
            sut = Cells(4, "P").Value
            If dic.exists(tercih) Then
                kalan = dic.Item(tercih)
                If kalan > 0 Then
                    Cells(i, "M").Resize(, 5).Interior.Color = vbYellow
                    kalan = kalan - 1
                    dic.Item(tercih) = kalan
                End If
            End If
        End If
    Next i
    degisti = False
    With CreateObject("Scripting.Dictionary")

        For i = 4 To son
            If Cells(i, "M").Interior.Color = vbYellow Then
                aday = Cells(i, "O").Value
                sira = Cells(i, "P").Value
                If Not .exists(aday) Then
                    .Item(aday) = Array(sira, i)
                Else
                    degisti = True
                    al = .Item(aday)
                    If al(0) > sira Then
                        Cells(al(1), "M").Resize(, 5).Interior.Color = rgbSilver
                        al(0) = sira
                        al(1) = i
                        .Item(aday) = al
                    Else
                        Cells(i, "M").Resize(, 5).Interior.Color = rgbSilver
                    End If
                End If
            End If
        Next i
        .RemoveAll

        For i = 4 To son
            If Cells(i, "M").Interior.Color <> rgbSilver Then
                aday = Cells(i, "O").Value
                sira = Cells(i, "P").Value
                If Not .exists(aday) Then
                    .Item(aday) = Array(sira, i)
                Else
                    al = .Item(aday)
                    If al(0) > sira Then
                        al(0) = sira
                        al(1) = i
                        .Item(aday) = al
                    End If
                End If
            End If
        Next i

        For i = 4 To son
            [L:K].Interior.Color = xlNone
            If Cells(i, "M").Interior.Color = vbYellow Then
                aday = Cells(i, "O").Value
                al = .Item(aday)
                If Cells(al(1), "M").Interior.Color = vbYellow Then
                    If al(1) <> i Then
                        Cells(i, "M").Resize(, 5).Interior.Color = rgbSilver
                        degisti = True
                    End If
                End If
            End If
        Next i

    End With
    If degisti Then yerlestir

    For i = 4 To son
        If Cells(i, "M").Interior.Color = vbYellow Then
            sat = Cells(i, "Q").Value
            sut = Cells(i, "P").Value
            Cells(sat, "H").Resize(, 3).Interior.Color = vbRed
            Cells(sat, sut).Interior.Color = vbGreen
            Select Case Cells(i, "N").Value
                Case "A", "B", "C": sut = 1
                Case "D", "E", "F": sut = 2
                Case "G", "H": sut = 3
            End Select
            Cells(sat, sut).Interior.Color = vbGreen
        End If
    Next i

End Sub

 

[Muhammet Okumuş]

Çalışmanız çok hızlı yerleştirme yapıyor. Kendi dosyama uyarlıyordum. Kısır döngüye giriyor sanırım.

 

[Muhammet Okumuş]

Sonunda mantığını ben de çözdüm. Sonra ne zeki insanlar var dedim. Destek veren herkese çok teşekkürler.