Hücredeki sayıyı diğer hücrelere dağıtma?

[mhmtkync]

Arkadaşlar içinden çıkamadığım bir durumla karşı karşıya kaldım. Bu konudaki yardımlarınızı bekliyorum. Bir öğretmen arkadaşım için 25 soruluk bir teste göre sonuç analizi programı yapmam gerekiyor. Elimde hazır bir şablon var, sonuç kısmı doldurulduğu zaman grafiklere dağıtıyor. Fakat istediğimiz şey 25 soruluk sonuçları tek tek girmek yerine toplam sonuç kısmına alınan toplam sonucu yazıp aynı satırdaki 25 hücreye bunu notun değerine göre dağıtması. Örnek verecek olursak toplam sonucu 56 olan bir öğrenci için 25 hücreden rastgele 14 tanesi "4" puan şeklinde geri kalanlar ise "0" puan şeklinde olacaktır. Önemli olan noktalardan birisi de rastgele dağıtması. Şimdiden teşekür ederim.

 

[mhmtkync]

Arkadaşlar yardımcı olacak kimse yok mu? En azından yol göstermeniz bile çok önemli benim için

 

[Muhammet Okumuş]

Merhaba,
Soruların puan değeri değişken mi? Yoksa hepsi 4 puan mı?

 

[mhmtkync]

soruların hepsi 4 puan.

 

[Muhammet Okumuş]

Kodu deneyiniz. AD sütununa notları el ile giriniz.

Sub Dağıt()
Application.ScreenUpdating = False
Range("E10:AC47") = ""
son = Range("AD48").End(3).Row
For i = 10 To son
If Cells(i, "AD") = "" Or Not IsNumeric(Cells(i, "AD")) Then GoTo 10
sayı = Range("AD" & i).Value
1
Range("E" & i & ":AC" & i) = Range("E9:AC9").Value
If sayı = 100 Then GoTo 10
5
a = WorksheetFunction.RandBetween(5, 29)
If Cells(i, a) < Cells(9, a) Then GoTo 5
Cells(i, a) = Cells(i, a) - Cells(9, a)
y = WorksheetFunction.Sum(Range("E" & i & ":AC" & i))
If sayı > y Then GoTo 1
If y <> sayı Then GoTo 5

10
Next
End Sub

 

[mhmtkync]

Üstadım kodu denemeye çalıştım ve AD sütünuna 0 veya 4'ün katı olan bir değer girdim fakat ben mi yapadım bir değişiklik olmadı daha sonra makro izin ayarlarında tümünü etkinleştir yapınca da vb hatası aldım. RT ERR 28

 

[Muhammet Okumuş]

Hatalı dosyayı ekleyiniz.

 

[mhmtkync]

Dosya ektetir

Hatalı dosyayı ekleyiniz.

 

[Muhammet Okumuş]

E9:AC9 satırları arasına puan değerlerini giriniz.

 

[Muhammet Okumuş]

Ayrıca;

=EĞER(VE(E12="";F12="";G12="";H12="";I12="";J12="";K12="";L12="";M12="";N12="";O12="";P12="";Q12="";R12="";S12="";T12="";U12="";V12="";W12="";X12="";Y12="";AA12="";AB12="";AC12="");"";TOPLAM(E12:AC12))

Bu kadar uzun formül yazmak yerine

=EĞER(BAĞ_DEĞ_SAY(E12:AC12)=0;"";TOPLAM(E12:AC12))

formülünü kullanınız.

 

[mhmtkync]

değerleri girdim ama rt hataları almaya devam ediyorum.

E9:AC9 satırları arasına puan değerlerini giriniz.

 

[Muhammet Okumuş]

Dosyanız nerde hata veriyor incelemedim. Benim eklemiş olduğum dosyayı inceleyiniz.

 

[Muhammet Okumuş]

Hatayı şimdi anladım. AD sütununda yer alan formülleri silmeniz gerekiyordu.

 

[mhmtkync]

Dosyayı denedim şu an için hiç bir sıkıntı yok. Teşekkür ederim Muhammed Bey.
Çalışmalarınızda başarılar dilerim.

 

[Muhammet Okumuş]

Rica ederim. Size de iyi çalışmalar.

 

[hkaradag]

Dosyanız nerde hata veriyor incelemedim. Benim eklemiş olduğum dosyayı inceleyiniz.

Alıntıladığım mesajdaki dosyanın 20 soruluk halini nasıl yapabiliriz? Her sorunun 5 puan olmasını istediğim 20 soruluk bir analiz yapmaya çalışıyorum. "Dağıt" makrosunda değişiklik yapmaya çalıştım olmadı. @Muhammet Okumuş hocam yardımcı olur musunuz? Teşekkür ederim.

 

[Muhammet Okumuş]

Sub Dağıt()
Application.ScreenUpdating = False
Range("E10:X47") = ""
son = Range("AD48").End(3).Row

For i = 10 To son
If Cells(i, "AD") = "" Or Not IsNumeric(Cells(i, "AD")) Then GoTo 10


Range("E" & i & ":X" & i) = Range("E9:X9").Value
If Range("AD" & i) = WorksheetFunction.Sum(Range("E" & i & ":X" & i)) Then GoTo 10
5
a = WorksheetFunction.RandBetween(5, 24)
If Cells(i, a) = 0 Then GoTo 5
Cells(i, a) = Cells(i, a) - 1

If Range("AD" & i) <> WorksheetFunction.Sum(Range("E" & i & ":X" & i)) Then GoTo 5


10
Next
End Sub

Kodu deneyiniz.

 

[hkaradag]

Kodu deneyiniz.

Çok teşekkürler hocam. Ellerinize sağlık.

 

[hkaradag]

@Muhammet Okumuş Hocam selamlar. Ekteki gibi 20 ve 25 soruluk iki analiz tablosu düzenlemeye çalışıyorum. Ancak makrolar çalışmıyor program donuyor. Yardımcı olabilir misiniz? Teşekkür ederim.

 

[Muhammet Okumuş]

For i = 10 to son yerine For i = 31 To 65 kullanınız. Ve Y sütununda değerler olmalı. 20 soruluk için baktım.