Verilen Toplamın, Toplananlarını Rastgele Dağıtma

[Muhammet Okumuş]

Rica ederim Hocam. İyi çalışmalar...

 

[tocy41]

Rica ederim Hocam. İyi çalışmalar...

Hocam birde; 9 toplanana değilde 6 toplanana dağıtsak kodda nasıl bir değişiklik yapmamız gerekir. Yani E17 den J17 ye kadar dağıtılacak olsa toplananlar ve oranlarda 50 -10-10-10-10-10 olsa....


.

 

[Muhammet Okumuş]

Eğer biraz kod bilginiz var ise değerleri N ye göre değil de K sütununa göre almalısınız.

 

[tocy41]

Eğer biraz kod bilginiz var ise değerleri N ye göre değil de K sütununa göre almalısınız.

Kod bilgim yok!.. Ama yardımlarınız için çok sağolun. İyi geceler...

.

 

[Muhammet Okumuş]

Dosyayı inceleyiniz.

 

[BAZGİRET]

Yukarıda yer alan dosyaları inceledim ancak kendi dosyama bir türlü uyarlayamadım. Açıklamayı ekli dosyanın içinde yaptım. Yardımlarınız için şimdiden teşekkürler.

 

[Muhammet Okumuş]

Fark 4'e kadar izin veriyor. J sütunu dikkate alınmamıştır.

Sub Dağıt()
Application.ScreenUpdating = False
Dim son, a, i As Byte
son = Range("K100").End(3).Row
Range("D7:J" & son) = ""
Range("M7:M" & son).Formula = "=SUM(D7:J7)"
Range("N7:N" & son).Formula = "=MAX(D7:I7)"
Range("O7:O" & son).Formula = "=MIN(D7:I7)"
Range("P7" & son).Formula = "=N7-O7"
For i = 7 To son
Range("D5:J5").Copy Cells(i, 4)
başla:
Do Until Cells(i, 11) = Cells(i, 13)

Randomize Timer
a = Int(Rnd() * 7 + 4)
If Cells(i, a) = 1 Then GoTo 10
Cells(i, a) = Cells(i, a) - 1
10
If Cells(i, 16) > 4 Then 'Arada oluşabilecek maksimum fark
Cells(i, a) = Cells(i, a) + 1
GoTo başla
End If
Loop

Next i

Range("M7" & son) = ""
End Sub

 

[BAZGİRET]

Fark 4'e kadar izin veriyor. J sütunu dikkate alınmamıştır.

Hocam ilgi ve yardımınız için teşekkürler. İşimi çok hafiflettiniz minnettarım. İyi çalışmalar diliyorum..

 

[Muhammet Okumuş]

Rica ederim. İyi çalışmalar.

 

[BAZGİRET]

Bilgisayarımdaki çalışmanın orjinal ve olması gereken halini yükledim. Dağıt düğmesine basılınca Excel yanıt vermiyor. Bunu halledebilirsek çok sevineceğim.

 

[Muhammet Okumuş]

Merhaba,
Kodun
For i = 7 To son
kısmını
For i = 7 To 41 yapınız.

 

[Muhammet Okumuş]

Kodu değiştiriniz. Ölçütlerin toplamı 100 olmalı.

Sub Düğme1_Tıklat()
Application.ScreenUpdating = False
Dim son, a, i As Byte
son = Range("M100").End(3).Row
Range("D7:J" & son) = ""
Range("N7:N" & son).Formula = "=SUM(D7:J7)"
Range("O7:O" & son).Formula = "=MAX(D7:I7)"
Range("P7" & son).Formula = "=MIN(D7:I7)"
Range("Q7:Q" & son).Formula = "=O7-P7"
For i = 7 To son
Range("D5:J5").Copy Cells(i, 4)
başla:
Do Until Cells(i, 11) = Cells(i, 14)

Randomize Timer
a = Int(Rnd() * 7 + 4)
If Cells(i, a) = 0 Then GoTo 10
Cells(i, a) = Cells(i, a) - 1
10
If Cells(i, 17) > 4 Then 'Arada oluşabilecek maksimum fark
Cells(i, a) = Cells(i, a) + 1
GoTo başla
End If
Loop

Next i

Range("N7:Q" & son) = ""
Range("P7").Select
End Sub