• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

LGS Puanına göre okulları getirme.

P

pisagor26

Katılım
18 Kasım 2009
Mesajlar
228
Excel Vers. ve Dili
excel 2007 türkçe
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

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:
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...:(
 
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
 
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.
Geri
Üst