LGS Puanına göre okulları getirme.

P

pisagor26

Altın Üye
Katılım
18 Kasım 2009
Mesajlar
206
Excel Vers. ve Dili
excel 2007 türkçe
Altın Üyelik Bitiş Tarihi
02-01-2026
değerli arkadaşlar okulumuzda yapılan deneme sınavları sonuçlarına göre öğrencilerin bu sınavlardaki aldıkları puanlara göre yerleşebilecekleri okulları görmesi adına bir çalışma yapmak istiyorum. Ekte yer alan çalışmada LİSTE sayfasında yer alan sınav sonuçlarına (puan) göre A sayfasında taban puanları yer alan okullardan girebilecekleri (puanı yeterli) okullardan ilk 5'ini getirmesini istiyorum. Yardımlarınızı bekliyorum...Teşekkürler...
 

Ekli dosyalar

YUSUF44

YUSUF44

Destek Ekibi
Destek Ekibi
Katılım
4 Ocak 2006
Mesajlar
12,073
Excel Vers. ve Dili
İş : Ofis 365 - Türkçe
Ev: Ofis 365 - Türkçe
Aşağıdaki kodları bir modüle kopyalayıp deneyiniz:

PHP: 
Sub LGS()
    Set s1 = Sheets("A")
    Set s2 = Sheets("LİSTE")
    son1 = WorksheetFunction.Max(2, s1.Cells(Rows.Count, "B").End(3).Row)
    son2 = WorksheetFunction.Max(2, s2.Cells(Rows.Count, "B").End(3).Row)
    s2.Range("D2:D" & son2) = ""
    s1.Sort.SortFields.Clear
    s1.Sort.SortFields.Add Key:=Range("C6"), SortOn _
        :=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortTextAsNumbers
    With s1.Sort
        .SetRange Range("A2:C" & son1)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
   
    For ogrenci = 2 To son2
        a = 0
        For okul = 2 To son1
            If s1.Cells(okul, "C") <= s2.Cells(ogrenci, "C") Then
                If a < 5 Then
                    If s2.Cells(ogrenci, "D") = "" Then
                        s2.Cells(ogrenci, "D") = a + 1 & "- " & s1.Cells(okul, "B")
                    Else
                        s2.Cells(ogrenci, "D") = s2.Cells(ogrenci, "D") & Chr(10) & a + 1 & "- " & s1.Cells(okul, "B")
                    End If
                    a = a + 1
                End If
            End If
        Next
        If a = 0 Then
            s2.Cells(ogrenci, "D") = "HİÇBİR OKULU KAZANAMADINIZ…"
        End If
    Next
    Cells.EntireRow.AutoFit
    MsgBox "İşlem Tamamlandı", vbInformation
End Sub
 
Son düzenleme:
P

pisagor26

Altın Üye
Katılım
18 Kasım 2009
Mesajlar
206
Excel Vers. ve Dili
excel 2007 türkçe
Altın Üyelik Bitiş Tarihi
02-01-2026
Elinize sağlık...Çok teşekkür ediyorum...
 
P

pisagor26

Altın Üye
Katılım
18 Kasım 2009
Mesajlar
206
Excel Vers. ve Dili
excel 2007 türkçe
Altın Üyelik Bitiş Tarihi
02-01-2026
YUSUF44' Alıntı:
Aşağıdaki kodları bir modüle kopyalayıp deneyiniz:

PHP: 
Sub LGS()
    Set s1 = Sheets("A")
    Set s2 = Sheets("LİSTE")
    son1 = WorksheetFunction.Max(2, s1.Cells(Rows.Count, "B").End(3).Row)
    son2 = WorksheetFunction.Max(2, s2.Cells(Rows.Count, "B").End(3).Row)
    s2.Range("D2:D" & son2) = ""
    s1.Sort.SortFields.Clear
    s1.Sort.SortFields.Add Key:=Range("C6"), SortOn _
        :=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortTextAsNumbers
    With s1.Sort
        .SetRange Range("A2:C" & son1)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
   
    For ogrenci = 2 To son2
        a = 0
        For okul = 2 To son1
            If s1.Cells(okul, "C") <= s2.Cells(ogrenci, "C") Then
                If a < 5 Then
                    If s2.Cells(ogrenci, "D") = "" Then
                        s2.Cells(ogrenci, "D") = a + 1 & "- " & s1.Cells(okul, "B")
                    Else
                        s2.Cells(ogrenci, "D") = s2.Cells(ogrenci, "D") & Chr(10) & a + 1 & "- " & s1.Cells(okul, "B")
                    End If
                    a = a + 1
                End If
            End If
        Next
        If a = 0 Then
            s2.Cells(ogrenci, "D") = "HİÇ BİR OKULU KAZANAMADINIZ…"
        End If
    Next
    Cells.EntireRow.AutoFit
    MsgBox "İşlem Tamamlandı", vbInformation
End Sub
Genişletmek için tıkla ...
getirilen okulları arada virgül olacak şekilde nasıl düzenleyebiliriz...:(
 
YUSUF44

YUSUF44

Destek Ekibi
Destek Ekibi
Katılım
4 Ocak 2006
Mesajlar
12,073
Excel Vers. ve Dili
İş : Ofis 365 - Türkçe
Ev: Ofis 365 - Türkçe
Aşağıdaki gibi deneyin:

PHP: 
Sub LGS()
    Set s1 = Sheets("A")
    Set s2 = Sheets("LİSTE")
    son1 = WorksheetFunction.Max(2, s1.Cells(Rows.Count, "B").End(3).Row)
    son2 = WorksheetFunction.Max(2, s2.Cells(Rows.Count, "B").End(3).Row)
    s2.Range("D2:D" & son2) = ""
    s1.Sort.SortFields.Clear
    s1.Sort.SortFields.Add Key:=Range("C6"), SortOn _
        :=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortTextAsNumbers
    With s1.Sort
        .SetRange Range("A2:C" & son1)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
   
    For ogrenci = 2 To son2
        a = 0
        For okul = 2 To son1
            If s1.Cells(okul, "C") <= s2.Cells(ogrenci, "C") Then
                If a < 5 Then
                    If s2.Cells(ogrenci, "D") = "" Then
                        s2.Cells(ogrenci, "D") = s1.Cells(okul, "B")
                    Else
                        s2.Cells(ogrenci, "D") = s2.Cells(ogrenci, "D") & ", " & s1.Cells(okul, "B")
                    End If
                    a = a + 1
                End If
            End If
        Next
        If a = 0 Then
            s2.Cells(ogrenci, "D") = "HİÇBİR OKULU KAZANAMADINIZ…"
        End If
    Next
    Cells.EntireRow.AutoFit
    MsgBox "İşlem Tamamlandı", vbInformation
End Sub
 
P

pisagor26

Altın Üye
Katılım
18 Kasım 2009
Mesajlar
206
Excel Vers. ve Dili
excel 2007 türkçe
Altın Üyelik Bitiş Tarihi
02-01-2026
YUSUF44' Alıntı:
Aşağıdaki gibi deneyin:

PHP: 
Sub LGS()
    Set s1 = Sheets("A")
    Set s2 = Sheets("LİSTE")
    son1 = WorksheetFunction.Max(2, s1.Cells(Rows.Count, "B").End(3).Row)
    son2 = WorksheetFunction.Max(2, s2.Cells(Rows.Count, "B").End(3).Row)
    s2.Range("D2:D" & son2) = ""
    s1.Sort.SortFields.Clear
    s1.Sort.SortFields.Add Key:=Range("C6"), SortOn _
        :=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortTextAsNumbers
    With s1.Sort
        .SetRange Range("A2:C" & son1)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
  
    For ogrenci = 2 To son2
        a = 0
        For okul = 2 To son1
            If s1.Cells(okul, "C") <= s2.Cells(ogrenci, "C") Then
                If a < 5 Then
                    If s2.Cells(ogrenci, "D") = "" Then
                        s2.Cells(ogrenci, "D") = s1.Cells(okul, "B")
                    Else
                        s2.Cells(ogrenci, "D") = s2.Cells(ogrenci, "D") & ", " & s1.Cells(okul, "B")
                    End If
                    a = a + 1
                End If
            End If
        Next
        If a = 0 Then
            s2.Cells(ogrenci, "D") = "HİÇBİR OKULU KAZANAMADINIZ…"
        End If
    Next
    Cells.EntireRow.AutoFit
    MsgBox "İşlem Tamamlandı", vbInformation
End Sub
Genişletmek için tıkla ...
Teşekkürler...elinize sağlik...
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst