toplam değeri sutunlara rastgele dağıtma

[fsahinoglu]

Merhaba arkadaşlar foruma yeni uye oldum malum excel de pek alışık değilim sorunum öğrencilerime toplam notu verdikten sonra toplam notu 5 sutuna rastgale dağıtmasını sağlamak

=($G13-MOD($G13;5))/5+EĞER(MOD($G13;5)>0;1;0)
=($G13-MOD($G13;5))/5+EĞER(MOD($G13;5)>1;1;0)
=($G13-MOD($G13;5))/5+EĞER(MOD($G13;5)>2;1;0)
=($G13-MOD($G13;5))/5+EĞER(MOD($G13;5)>3;1;0)
=($G13-MOD($G13;5))/5+EĞER(MOD($G13;5)>4;1;0)

5 tane sutuna yazdığım kod bu ama değerler aynı oluyor

10 10 10 10 10 50 (60 yaparsam)
12 12 12 12 12 Toplam(60)

bu şekilde oluyor bir sutunun max 20 puan alması ve rastgele değerler üretmesini istiyorum olmuyor ne yazmam gerek çözemedim

5 10 10 15 20 toplam (60) gibi

 

[Korhan Ayhan]

Merhaba,

Forumumuza hoşgeldiniz.

Aşağıdaki linkte benzer bir konu işlenmişti. İnceleyiniz.

Rastgelearada

 

[Muhammet Okumuş]

Dosya 7 ölçütlü.

 

[fsahinoglu]

her iki arkadaşıma çok tşk ederim

korhan ayhan sizin bir arkadaşa yapmış olduğunuz uygulama kasıyor.
muhammet okumuş vip uyeliğim yok dosya indiremiiyorum

netten sağdan soldan bulduğum vb kodlamayla birşeyler yaptım çok sağolun veridğiniz linkler bana yol gösterdi.
tşk ederim

 

[Muhammet Okumuş]

Sub Dağıt()
Application.ScreenUpdating = False
son = Cells(Rows.Count, "K").End(3).Row
For i = 7 To son
If Not IsNumeric(Cells(i, 11)) Or Cells(i, 11) = "" Then GoTo 100
Range("D" & i & ":J" & i) = Range("D5:J5").Value
If WorksheetFunction.Sum(Range("D" & i & ":J" & i)) = Range("K" & i) Then GoTo 10
5
Randomize
a = WorksheetFunction.RandBetween(4, 10)
If Cells(i, a) = Cells(6, a) Then GoTo 5
Cells(i, a) = Cells(i, a) - 5
10
If WorksheetFunction.Sum(Range("D" & i & ":J" & i)) <> Range("K" & i) Then GoTo 5
100
Next
End Sub

Kodlar bu şekilde.

 

[Korhan Ayhan]

Bulduğunuz çözümü bizimle paylaşmak ister misiniz?

 

[fsahinoglu]

bende çözüm basit ama arkada kodları yazmak biraz hamallık istiyor. rastgele sayı atamayı düşünmüştüm fakat o değeri bulana kadar bilgisayar kasıyor yada beklemeye alıyor
öğretmenler not verirken genelde 5 in katlarını kullanır aradaki değerleri kullanmazlar bende 5 in katları ve ölçekteki duruma göre değerlerle oynadım

Sub perf_d1()

Dim a As Byte

For a = 7 To Range("A1").Value + 7
If Cells(a, 9) = 100 Then
Cells(a, 4) = 20
Cells(a, 5) = 20
Cells(a, 6) = 20
Cells(a, 7) = 20
Cells(a, 8) = 20

ElseIf Cells(a, 9) = 95 Then
Cells(a, 4) = 20
Cells(a, 5) = 20
Cells(a, 6) = 20
Cells(a, 7) = 20
Cells(a, 8) = 15

ElseIf Cells(a, 9) = 90 Then
Cells(a, 4) = 20
Cells(a, 5) = 20
Cells(a, 6) = 15
Cells(a, 7) = 20
Cells(a, 8) = 15

ElseIf Cells(a, 9) = 85 Then
Cells(a, 4) = 20
Cells(a, 5) = 20
Cells(a, 6) = 15
Cells(a, 7) = 15
Cells(a, 8) = 15

ElseIf Cells(a, 9) = 80 Then
Cells(a, 4) = 20
Cells(a, 5) = 20
Cells(a, 6) = 15
Cells(a, 7) = 10
Cells(a, 8) = 15

ElseIf Cells(a, 9) = 75 Then
Cells(a, 4) = 20
Cells(a, 5) = 15
Cells(a, 6) = 15
Cells(a, 7) = 15
Cells(a, 8) = 10

ElseIf Cells(a, 9) = 70 Then
Cells(a, 4) = 15
Cells(a, 5) = 15
Cells(a, 6) = 10
Cells(a, 7) = 15
Cells(a, 8) = 15

ElseIf Cells(a, 9) = 65 Then
Cells(a, 4) = 15
Cells(a, 5) = 15
Cells(a, 6) = 15
Cells(a, 7) = 10
Cells(a, 8) = 10

ElseIf Cells(a, 9) = 60 Then
Cells(a, 4) = 15
Cells(a, 5) = 15
Cells(a, 6) = 10
Cells(a, 7) = 10
Cells(a, 8) = 10

ElseIf Cells(a, 9) = 55 Then
Cells(a, 4) = 15
Cells(a, 5) = 10
Cells(a, 6) = 10
Cells(a, 7) = 10
Cells(a, 8) = 10

ElseIf Cells(a, 9) = 50 Then
Cells(a, 4) = 10
Cells(a, 5) = 10
Cells(a, 6) = 10
Cells(a, 7) = 10
Cells(a, 8) = 10

ElseIf Cells(a, 9) = 45 Then
Cells(a, 4) = 10
Cells(a, 5) = 10
Cells(a, 6) = 10
Cells(a, 7) = 10
Cells(a, 8) = 5

ElseIf Cells(a, 9) = 40 Then
Cells(a, 4) = 10
Cells(a, 5) = 10
Cells(a, 6) = 10
Cells(a, 7) = 5
Cells(a, 8) = 5

ElseIf Cells(a, 9) = 35 Then
Cells(a, 4) = 10
Cells(a, 5) = 10
Cells(a, 6) = 5
Cells(a, 7) = 5
Cells(a, 8) = 5

ElseIf Cells(a, 9) = 30 Then
Cells(a, 4) = 10
Cells(a, 5) = 5
Cells(a, 6) = 5
Cells(a, 7) = 5
Cells(a, 8) = 5

End If
Next
End Sub


// butona basınca a() tagın içindeki per_d1 kodu tetikliyor
Sub a()
Call perf_d1


End Sub

// hesapla adında butonum var
Sub hesapla()
Call a
End Sub


aslında yukarıdaki kodda geliştirilebilir misal

ElseIf Cells(a, 9) = 35 Then
Cells(a, 4) = 10
Cells(a, 5) = 10
Cells(a, 6) = 5
Cells(a, 7) = 5
Cells(a, 8) = 5

35 alan 5 kişi aynı sutundaki değerler aynı alacak fakat random olarak dağıtılırsa süper olacak kod bilgim yok bakarak deneyerek öğrendim

 

[Muhammet Okumuş]

Hocam sizin 55 değeri aynı notları verir.
20-10-15-5-5 olma ihtimali yok
http://www.dosya.tc/server2/67191n/Performans_Olcek.rar.html
Dosyayı inceleyiniz. Ama 45 altı için not vermez. en az 45 notunu vermelisiniz.
45ten küçük notunuz varsa D6:J6 arasındaki değerleri küçültünüz.

Notlarınız 5'in katı olmalı. Eğer 5'in katı olmasın derseniz koddaki
Cells(i, a) = Cells(i, a) - 5
5 olan değeri 1 yapınız.

 

[Korhan Ayhan]

Alternatif;

Örnek Dosya

 

[Muhammet Okumuş]

Korhan Bey, ölçütlerin 20'nin üzerine çıktığı oluyor. İşlem çok uzun sürüyor. En kısa yol bana göre her öğrenciye başta 0 veya 100 vermek. Not değerine ulaşıncaya kadar sayı eklemek veya çıkarmak.

 

[fsahinoglu]

elinize sağlık güzel örnekler verdiniz çok sağolun
ben olayı butondan çıkarıp misal ilgili sutuna tıklandığında otomatik hesaplama yapmak istiyorum fakat buradaki döngüyü nasıl çohaltabilirim misal
1 sayfamda 3 tane not var 1. performans 2. performans ve ürün dosyası
1. performansın notunu girdiğimde hesaplasın ve diğerlerinde onun için


Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [N6:N200]) Is Nothing Then Exit Sub
Call 1.performans
else If Intersect(Target, [S6:S200]) Is Nothing Then Exit Sub
Call 2.performans
else If Intersect(Target, [Y6:Y200]) Is Nothing Then Exit Sub
Call 2.performans

end if
End Sub

şeklinde ama saçma oldu sanırım

 

[Muhammet Okumuş]

Dosyanızı paylaşım sitesine yükleyiniz.

 

[fsahinoglu]

http://s5.dosya.tc/server3/gs2rim/otomat_not_olcek.rar.html

 

[Muhammet Okumuş]

Düğme ile hepsinin aynı anda hesaplanmasını istemiyor musunuz?

 

[fsahinoglu]

düğmelisini yapmıştım beğenmedim ellen girilince hesaplanması daha mantıklı gelmişti onunla uğraşıyorum çözemedim mesele I sutunundaki o ve u sutuna göre ayarlayamadım.
sizin çalışmanız misal düğmeli şöyle düşündüm hesaplattırdım çıktı aldım sonra tekrar düğmeye bastığımda çıktıdaki notlar aynı olmayacak o yüzden ellen bir kere girilsin dursun o mantık yanlışlıkla düğmeye bastığında bazen işlemleri geri alamıyorsun yada ben beceremedim.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [ı6:ı200]) Is Nothing Then Exit Sub
Call perf_d1
End Sub

 

[Muhammet Okumuş]

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("I6:I200")) Is Nothing Then GoTo 1
x = Target.Row
nott = Cells(x, 9).Value
Range("D" & x & ":H" & x) = 20
If Cells(x, 9) = 100 Then Exit Sub
10
b = WorksheetFunction.RandBetween(4, 8)
If Cells(x, b) = 0 Then GoTo 10
Cells(x, b) = Cells(x, b) - 5
If WorksheetFunction.Sum(Range("D" & x & ":H" & x)) = nott Then Exit Sub
GoTo 10
1
If Intersect(Target, Range("O6:O200")) Is Nothing Then GoTo 2
x = Target.Row
nott = Cells(x, 15).Value
Range("J" & x & ":N" & x) = 20
If Cells(x, 15) = 100 Then Exit Sub
20
b = WorksheetFunction.RandBetween(10, 14)
If Cells(x, b) = 0 Then GoTo 10
Cells(x, b) = Cells(x, b) - 5
If WorksheetFunction.Sum(Range("J" & x & ":N" & x)) = nott Then Exit Sub
GoTo 20
2
If Intersect(Target, Range("U6:U200")) Is Nothing Then GoTo 3
x = Target.Row
nott = Cells(x, 21).Value
Range("P" & x & ":T" & x) = 20
If Cells(x, 21) = 100 Then Exit Sub
30
b = WorksheetFunction.RandBetween(16, 20)
If Cells(x, b) = 0 Then GoTo 30
Cells(x, b) = Cells(x, b) - 5
If WorksheetFunction.Sum(Range("P" & x & ":T" & x)) = nott Then Exit Sub
GoTo 30
3
End Sub

Kodu deneyiniz. 5'in katlarında çalışır.

 

[fsahinoglu]

tek sorun 40 dan aşağıya not girince excel patlıyor onun haricinde çok harika çalışıyor eline sağlık.

 

[fsahinoglu]

Cells(x, b) = Cells(x, b) - 1 yaparsak 1 katları oluyor unutmadıysam

 

[Muhammet Okumuş]

30
b = WorksheetFunction.RandBetween(16, 20)
If Cells(x, b) = 0 Then GoTo 10

10 yerine 30 yazın. Kodu kopyalayınca değiştirmeden kalmış.

Bir de şu sorun olabiliyor. Örneğin 20 dediğimizde bir değer 20 iken diğerleri 0 olabiliyor.Eğer bu sorun ise bunu engelleyebiliriz.

 

[Muhammet Okumuş]

1 yaparsanız 20 den aşağıya 1 er 1 er düşer. 3 yaparsanız 3'ün katı olmaz. 17,14,11,8 gibi sayılar gelebilir.