• DİKKAT

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

Hücrelere belirli bir kurala göre sayı dağılımı

  • Konbuyu başlatan Konbuyu başlatan kadu5
  • Başlangıç tarihi Başlangıç tarihi
K

kadu5

Katılım
24 Haziran 2013
Mesajlar
25
Excel Vers. ve Dili
office 2010
Merhaba arkadaşlar. Bir konuda yardımınıza ihtiyacım oldu. Eklemiş olduğum dosyada 10 tane kritere 40 sayısı rastgele dağıtılması gerekiyor. Hücrelerde 0 olmamalı. . Örneğin 90 notu yazılınca 10 hücreye 36 rakamı (90/2,5=36) otomatik dağılmasını istiyorum ama beceremedim. Yardımcı olursanız sevinirim. Kısacası ben notu yazayım, notun 2.5'e bölümünden çıkan sayı 10 hücreye 0 olmayacak şekilde rastgele dağılmasını istiyorum. yardımcı olursanız çok sevineceğim teşekkürler.

https://drive.google.com/file/d/0B14wo6hY4wADd2pSeTZSYVVsbUE/edit?usp=sharing

https://drive.google.com/file/d/0B14wo6hY4wADak5aaEo2Z1I0d2c/edit?usp=sharing
 
Sayın hocam daha evvel bununla ilgili bir çalışmam olmuştu. İlgili yerleri kendinize göre değiştirip deneyebilirsiniz.
Makro kodları aşağıdadır.

Kod: 
Sub Performans_Degerlendir()
t = "X" 'Toplam puanın yazıldığı sütun
b = "A" 'Puanların başlangıç sütunu
v = 5 'Verilerin başlangıç satırı
vv = [A38].End(2).Row 'Verilerin bitiş satırı
kriter = 10  'Kaç kriter var
puan = 10 'Her kriter kaç puan
'AŞAĞIDAKİ KODLARI DEĞİŞTİRMEYİNİZ.
bs = Range(b & 1).Column
ss = bs + kriter - 1
s = Mid(Cells(1, ss).Address, 2, 1)
For j = v To vv
If Cells(j, t) < kriter Or Cells(j, t) > puan * kriter Then GoTo sonraki:
For i = bs To ss
Cells(j, i) = WorksheetFunction.RandBetween(1, puan)
Next i
If Cells(j, t) > WorksheetFunction.Sum(Range(b & j & ":" & s & j)) Then GoTo yuksek:
If Cells(j, t) < WorksheetFunction.Sum(Range(b & j & ":" & s & j)) Then GoTo dusuk:
sonraki:
Next j
Exit Sub
yuksek:
Do Until Cells(j, t) = WorksheetFunction.Sum(Range(b & j & ":" & s & j))
y = WorksheetFunction.RandBetween(bs, ss)
If Cells(j, y) < puan Then Cells(j, y) = Cells(j, y) + 1
If Cells(j, t) = WorksheetFunction.Sum(Range(b & j & ":" & s & j)) Then GoTo sonraki:
Loop
If Cells(j, t) > WorksheetFunction.Sum(Range(b & j & ":" & s & j)) Then GoTo yuksek:
dusuk:
Do Until Cells(j, t) = WorksheetFunction.Sum(Range(b & j & ":" & s & j))
d = WorksheetFunction.RandBetween(bs, ss)
If Cells(j, d) > 1 Then Cells(j, d) = Cells(j, d) - 1
If Cells(j, t) = WorksheetFunction.Sum(Range(b & j & ":" & s & j)) Then GoTo sonraki:
Loop
If Cells(j, t) < WorksheetFunction.Sum(Range(b & j & ":" & s & j)) Then GoTo dusuk:
GoTo sonraki:
End Sub
 
Son düzenleme:
mucit77' Alıntı:
Sayın hocam daha evvel bununla ilgili bir çalışmam olmuştu. İlgili yerleri kendinize göre değiştirip deneyebilirsiniz.
Makro kodları aşağıdadır.

Kod: 
Sub Performans_Degerlendir()
t = "M" 'Toplam puanın yazıldığı sütun
b = "B" 'Puanların başlangıç sütunu
v = 3 'Verilerin başlangıç satırı
vv = 30 'Verilerin bitiş satırı
kriter = 10  'Kaç kriter var
puan = 10 'Her kriter kaç puan
'AŞAĞIDAKİ KODLARI DEĞİŞTİRMEYİNİZ.
bs = Range(b & 1).Column
ss = bs + kriter - 1
s = Mid(Cells(1, ss).Address, 2, 1)
For j = v To vv
For i = bs To ss
Cells(j, i) = WorksheetFunction.RandBetween(1, puan)
Next i
If Cells(j, t) > WorksheetFunction.Sum(Range(b & j & ":" & s & j)) Then GoTo yuksek:
If Cells(j, t) < WorksheetFunction.Sum(Range(b & j & ":" & s & j)) Then GoTo dusuk:
deneme:
Next j
Exit Sub
yuksek:
Do Until Cells(j, t) = WorksheetFunction.Sum(Range(b & j & ":" & s & j))
y = WorksheetFunction.RandBetween(bs, ss)
If Cells(j, y) < puan Then Cells(j, y) = Cells(j, y) + 1
If Cells(j, t) = WorksheetFunction.Sum(Range(b & j & ":" & s & j)) Then GoTo deneme:
Loop
If Cells(j, t) > WorksheetFunction.Sum(Range(b & j & ":" & s & j)) Then GoTo yuksek:
dusuk:
Do Until Cells(j, t) = WorksheetFunction.Sum(Range(b & j & ":" & s & j))
d = WorksheetFunction.RandBetween(bs, ss)
If Cells(j, d) > 1 Then Cells(j, d) = Cells(j, d) - 1
If Cells(j, t) = WorksheetFunction.Sum(Range(b & j & ":" & s & j)) Then GoTo deneme:
Loop
If Cells(j, t) < WorksheetFunction.Sum(Range(b & j & ":" & s & j)) Then GoTo dusuk:
GoTo deneme:
End Sub
Genişletmek için tıkla ...

Hocam ben excelde kodlarla falan hiç çalışmadım bilmiyorum yani nereden nasıl düzenlenir. Deneme amaçlı makrolardan girdim kodu yapıştırdım kaydete basınca hata verdi ve yapamadım sana zahmet yukarıdaki dosyaya ekleyiversene yada hiç bilmeyen biri için anlatsana bende ona göre yapayım.
 
O zaman bir sorum olacak:
10 kriteriniz var, her kriter 10 puan mı? Yani 100 üzerinden mi not girmek istiyorsunuz.
Yoksa 40 üzerinden mi? O zaman da kriteriniz 4 puan oluyor.
Sayfaların çoğunda 10 puan olarak girmişsiniz. Birinde de 4 puan hangisini tercih edersiniz?
 
mucit77' Alıntı:
O zaman bir sorum olacak:
10 kriteriniz var, her kriter 10 puan mı? Yani 100 üzerinden mi not girmek istiyorsunuz.
Yoksa 40 üzerinden mi? O zaman da kriteriniz 4 puan oluyor.
Sayfaların çoğunda 10 puan olarak girmişsiniz. Birinde de 4 puan hangisini tercih edersiniz?
Genişletmek için tıkla ...

şöyle göstereyim
1. 2. 3. 4. 5. 6. 7. 8. 9. 10. toplam aldığı not
3 3 3 3 3 3 3 3 3 3 30 30*2,5=75

yukarıda 10 hücre en fazla 4 olacak şekilde yazılıyor. ben 75 puanı yazıp gerisini yukarıdaki gibi dağıtmasını istiyorum. Buda formülsüz yazılımış şekli.

edit


https://drive.google.com/file/d/0B14wo6hY4wADWmMwOGdpUEltdzg/edit?usp=sharing
 
L sütununa yazdığınız sayılara göre (10-40 aralığında) diğer hücreleri doldurur.
Sayfalarınızın formatları birbirinden farklı olduğu için diğer sayfalarda hata oluşacaktır, o yüzden bütün sayfalarınızı bu formata göre düzenleyiniz. Dosyanız ekte ve linktedir.

#İNDİR#
 

Ekli dosyalar

mucit77' Alıntı:
L sütununa yazdığınız sayılara göre (10-40 aralığında) diğer hücreleri doldurur.
Sayfalarınızın formatları birbirinden farklı olduğu için diğer sayfalarda hata oluşacaktır, o yüzden bütün sayfalarınızı bu formata göre düzenleyiniz. Dosyanız ekte ve linktedir.

#İNDİR#
Genişletmek için tıkla ...

Teşekkürler hocam eline sağlık.
 
Rica ederim kolay gelsin.
 
mucit77' Alıntı:
Rica ederim kolay gelsin.
Genişletmek için tıkla ...

Hocam kızacaksın ama son birşey sorabilir miyim?
notlar dağılırken 1 4 4 4 yerine 3 3 3 4 dağıtıla bilir mi acaba. bunu not gibi düşünürsek bir hücrede 4 varken diğerinde 1 olması kötü görünüyor da. Neredeyse her satırda 1 var o yüzden söyledim.
 
Kızacak bir şey yok :)
Gerçekçiliğini artırmak için o şekilde ayarlamıştım.
Birbirine yakın değerler olsun istiyorsanız kod içindeki

Kod: 
Cells(j, i) = WorksheetFunction.RandBetween(1, puan)

yazan satırı aşağıdakiyle değiştiriniz.

Kod: 
Cells(j, i) = Round(Cells(j, t) / kriter)

daha da yakın istiyorsanız farklı değişimler yapmak gerek, ancak zaten nette birbirine yakın değerler üreten çözümler mevcut.
 
Son düzenleme:
Tamam hocam şimdi oldu bu çok iyi teşekkür ederim:)
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst