Excelciler Lütfen Bir Kez Daha Yardım

Sayın hocam, otomatik not dağitma yaparken 10 tane kriterin puanları farklı olacak o sütuna yazdığımız değer o sütünun değerine kaç yazılmışsa o değerden ne altı ne yukarı olacak yani sabit olacak. Misal bir sutuna 8 yazmışsam oraya sadece 8 puan verecek diğerlerinede kaç yazmışsam o puane verecek aşağı yukarı olmayacak .Birde sağ tarafa 80 yazdım o sabit sayıları kullanarak otomatik not verecek .Bunun bir yolıu var mı yoksa öğrencilerin notunu tek tek girmek işkence.Bilen bir hocam akıl verebilir mi yardımcı olur musunuz?

takip

Hocam sondaki toplam puan hücresinin vereceğiniz puan değerine göre yüzdesini alabilirsiniz. Yani =Q12*0,08 8 puan verilenler =Q12*0,06 6 puan verilenler

Merhaba,

Sub Dağıt()
Application.ScreenUpdating = False
Dim a, i, son
son = Cells(Rows.Count, 17).End(3).Row
If son < 4 Then Exit Sub
For i = 4 To son
If Cells(i, 17) = "" Then GoTo 10
Range("D" & i & ": P" & i) = Range("D3: P3").Value
5
If WorksheetFunction.Sum(Range("D" & i & ": P" & i)) = Cells(i, 17) Then GoTo 10
15
a = WorksheetFunction.RandBetween(4, 16)
If Cells(i, a) = 0 Then GoTo 15
Cells(i, a) = Cells(i, a) - 1
GoTo 5
10
Next
End Sub

Genişletmek için tıkla ...

Kodu deneyiniz.

Takip

Teşekkür ederim sayın hocalarım,hallettik, dosyayı paylaşıyorum belki birinin işine yarar.

hocam teşekkür ederim harika çalışıyor sizinki bende not baremini ve soru sayısını değiştirsem en kolay nasıl yaparım, çok işime yarar

=100,10))))))))+IF(K21=0,0,IF(K21=25,5,IF(K21=30,5,IF(K21=35,10,IF(K21=45,5,IF(K21=55,10,IF(K21=65,10,IF(K21=75,10))))))))+IF(K21=95,10)

Öğrenciye 20 puan verince 0 0 0 0 0 0 şeklinde oluyor

Formül aynı nota aynı puanlamayi yapar. Verdiğim kodlari uyarlayiniz.

hocam nasıl ekliyoruz bu kodu örnek dosya eklermisiniz ?

losar' Alıntı:

hocam nasıl ekliyoruz bu kodu örnek dosya eklermisiniz ?

Genişletmek için tıkla ...

Dosyanızı ekleyin düzenleyeyim.

mokumus67' Alıntı:

Dosyanızı ekleyin düzenleyeyim.

Genişletmek için tıkla ...

hocam ayarlayınca eklerim teşekkürler sizinki de güzel çalışıyor

mokumus67' Alıntı:

Dosyanızı ekleyin düzenleyeyim.

Genişletmek için tıkla ...

Hocam bu haliyle tek kelimeyle inanılmaz güzel olmuş, not baremi ve sayısını kafama göre değiştirdim yinede güzel çalışıyor.Tamda evrensel bir rubrik olmuş.Tekrardan sağolun. Excel bilginize hayran oldum.saygılar

Hocam vaktiniz olursa birde yukarıdaki aynı dosyanızda13 soru değilde 20 sorulukta yaparsanız arşivlik bir çalışma olur. herbiri 5 puanlık. her sorudan ya 5 alacak yada sıfır.

Hocam ben size balık vermek yerine balık tutmasını öğreteyim.
Kodları açıklayacağım. Kendinize göre basitçe düzenleyebilirsiniz.
Sub Dağıt()
Application.ScreenUpdating = False 'İşlem yaparken ekranda gözükmez. Kodu hızlandırmak için yapılır.
Dim a, i, son
son = Cells(Rows.Count, 17).End(3).Row ' Son satırı verir. Bizim dosyamızda notlar Q sütununda. Q sütun numarası 17 dir. Eğer puanlar Z sütununda olsaydı 26 diyecektik. Veya 17 yerine tırnak içinde "Q" da yazılabilirdi. son = Cells(Rows.Count, "Q").End(3).Row


If son < 4 Then Exit Sub 'Eğer hiçbir öğrenciye puan verilmemişse kod işlem yapmadan çalışmasını bitirir.

For i = 4 To son İlk öğrenci 4. satırda olduğu için 4'ten başlattık. Eğer ilk Öğrenci 10. satırda olsa 4 to son yerine 10 to son dememiz gerekirdi.
If Cells(i, 17) = "" Then GoTo 10 'Eğer öğrencinin notu yoksa o öğrenciyi atla diyoruz.

Range("D" & i & ": P" & i) = Range("D3: P3").Value ' i satır değeri oluyor. i = 4 için ; 4. satırdaki öğrenciye D3: P3 de yazan not ölçeklerini yazıyoruz. Burdaki D: P aralığı esnek. Bu aralığı değiştirerek istediğimiz kadar ölçeklendirme yapabiliriz.

5
If WorksheetFunction.Sum(Range("D" & i & ": P" & i)) = Cells(i, 17) Then GoTo 10 ' eğer D ile P arası toplamı öğrenci notuna eşitse öğrenciyi artık notlandırmamak öğrenciyi döngüden çıkarıyoruz.
15
a = WorksheetFunction.RandBetween(4, 16) 'a değişkenine 4 ile 16 arası rastgele bir değer atıyoruz. D:4 sütun P 16. sütun olduğu için. 4 ve 16 ölçeklendirmenin yapılacağı sütun aralığını belirler.
If Cells(i, a) = 0 Then GoTo 15 'eğer notlandırma yapılacak hücre değeri sıfıra eşit ise tekrar a değişkenine tekrar değer atamak için 15 yazan satıra gönderiyoruz. Eğer bunu yazmazsak öğrenci eksi not alır.
Cells(i, a) = Cells(i, a) - 1 ' a değişkeninde yer alan sütundaki hücre değerinden çıkartıyoruz. İlk olarak öğrenciye 100 notunu veriyor. Sonra öğrencinin aldığı puan değerine gelinceye kadar ölçeklerden 1 puan düşüyor. Eğer ölçeklendirmeyi 5'in katı olarak yapmak istiyorsanız. Cells(i, a) = Cells(i, a) - 5 yazarsınız.
Ama bu durumda öğrenci notlandırması 5'in katı olmalı yoksa kod kısır döngüye girer.
GoTo 5 '5 yazan satır git diyoruz. Burdaki amaç öğrencinin notuna ulaşabildik mi diye.
10
Next
End Sub

Umarım anlatabilmişimdir.

Sub Dağıt()
Application.ScreenUpdating = False
Dim a, i, son
son = Cells(Rows.Count, 24).End(3).Row
If son < 4 Then Exit Sub
For i = 4 To son
If Cells(i, 17) = "" Then GoTo 10
Range("D" & i & ": P" & i) = Range("D3: W3").Value
5
If WorksheetFunction.Sum(Range("D" & i & ": P" & i)) = Cells(i, 17) Then GoTo 10
15
a = WorksheetFunction.RandBetween(4, 23)
If Cells(i, a) = 0 Then GoTo 15
Cells(i, a) = Cells(i, a) - 5
GoTo 5
10
Next
End Sub

kod yaptım lakin çalıştıramadım hocam nerede hata yaptım acaba ? yaptığım dosyayı ekledim

If Cells(i, 17) = "" Then GoTo 10 ------------ burda 17yi 24 yapmalısınız. Çünkü notlar 24. sütunda
Range("D" & i & ": P" & i) = Range("D3: W3").Value ---------------- Burdaki P sütununu W ile değiştirmelisiniz.
If WorksheetFunction.Sum(Range("D" & i & ":W" & i)) = Cells(i, 17) Then GoTo 10 -------------- 17 yi 24 yapmalısınız.

mokumus67' Alıntı:

If Cells(i, 17) = "" Then GoTo 10 ------------ burda 17yi 24 yapmalısınız. Çünkü notlar 24. sütunda
Range("D" & i & ": P" & i) = Range("D3: W3").Value ---------------- Burdaki P sütununu W ile değiştirmelisiniz.
If WorksheetFunction.Sum(Range("D" & i & ":W" & i)) = Cells(i, 17) Then GoTo 10 -------------- 17 yi 24 yapmalısınız.

Genişletmek için tıkla ...

deniyorum

Çalıştı hocam çok sağolun, ancak toplamı yanlış dağıtıyor

If WorksheetFunction.Sum(Range("D" & i & ": P" & i)) = Cells(i, 24) Then GoTo 10

Burdaki P yi de W yapın
If WorksheetFunction.Sum(Range("D" & i & ":W" & i)) = Cells(i, 24) Then GoTo 10

Sonunda oldu hocam varolun

Sub Düğme1_Tıkla()
Application.ScreenUpdating = False
Dim a, i, son
son = Cells(Rows.Count, 24).End(3).Row
If son < 4 Then Exit Sub
For i = 4 To son
If Cells(i, 24) = "" Then GoTo 10
Range("D" & i & ": w" & i) = Range("D3: W3").Value
5
If WorksheetFunction.Sum(Range("D" & i & ": w" & i)) = Cells(i, 24) Then GoTo 10
15
a = WorksheetFunction.RandBetween(4, 23)
If Cells(i, a) = 0 Then GoTo 15
Cells(i, a) = Cells(i, a) - 5
GoTo 5
10
Next
End Sub

Evet bu kez olmuş. Size iyi çalışmalar.

sağolun hocam

programda ne yapılmak isteniyor ben tam anlamadm