• DİKKAT

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

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

M

mhmtkync

Altın Üye
Katılım
9 Aralık 2014
Mesajlar
11
Excel Vers. ve Dili
Office 365
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.
 

Ekli dosyalar

Arkadaşlar yardımcı olacak kimse yok mu? En azından yol göstermeniz bile çok önemli benim için
 
Merhaba,
Soruların puan değeri değişken mi? Yoksa hepsi 4 puan mı?
 
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
Genişletmek için tıkla ...
 
Son düzenleme:
Ü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
 
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))
Genişletmek için tıkla ...
Bu kadar uzun formül yazmak yerine
=EĞER(BAĞ_DEĞ_SAY(E12:AC12)=0;"";TOPLAM(E12:AC12))
Genişletmek için tıkla ...
formülünü kullanınız.
 
Dosyanız nerde hata veriyor incelemedim. Benim eklemiş olduğum dosyayı inceleyiniz.
 

Ekli dosyalar

Hatayı şimdi anladım. AD sütununda yer alan formülleri silmeniz gerekiyordu.
 
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ş' Alıntı:
Dosyanız nerde hata veriyor incelemedim. Benim eklemiş olduğum dosyayı inceleyiniz.
Genişletmek için tıkla ...
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.
 
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
Genişletmek için tıkla ...

Kodu deneyiniz.
 
@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.
 

Ekli dosyalar

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.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst