Toplamları belli olan rasgele sayılar üretme

[ozan_ismail]

sayı üret.xlsm - 14 KB
Merhabalar, örnek dosyadaki gibi sayıların değeri 5'i geçmeyecek şekilde toplam hücresine girilen sayıyı elde edecek 20 adet rasgele sayı üretmek mümkün müdür?

 

[Muhammet Okumuş]

Merhaba,
Kodu deneyiniz.

Sub Rasstgele()
Range("A2:T2") = 5
10
If WorksheetFunction.Sum(Range("A2:T2")) = Range("U2") Then Exit Sub
5
a = WorksheetFunction.RandBetween(1, 20)
If Cells(2, a) = 0 Then GoTo 5
Cells(2, a) = Cells(2, a) - 1
GoTo 10
End Sub

 

[ozan_ismail]

Merhaba,
Kodu deneyiniz.

Muhammet bey öncelikle teşekkür ederim.
Bu kodu elle çalıştırmadan U2 hücresine rakamı girince kendisinin dağıtması için;
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [u2]) Is Nothing Then
Call Rasstgele
End If
End Sub bunun dışında bir yöntem var mıdır? Çünkü girilecek rakamlar U sütunu boyunca kullanıcıya göre aşağıya uzayacak.
Bir de U3 U4 U5 diye devam eden farklı rakamlar olacak. Makro sadece 2.satır için çalışmakta. Diğerleri için ayrı ayrı kodlar mı yazmalı mıyım? Bunun daha pratik bir yolu var mıdır?

 

[Muhammet Okumuş]

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim a, r As Byte
If Intersect(Target, Range("U2:U100")) Is Nothing Then Exit Sub

r = Target.Row
If Range("U" & r) > 100 Or Range("U" & r) < 20 Or Not IsNumeric(Range("U" & r)) Then Exit Sub
Range("A" & r & ":T" & r) = 5
10
If WorksheetFunction.Sum(Range("A" & r & ":T" & r)) = Range("U" & r) Then Exit Sub
5
a = WorksheetFunction.RandBetween(1, 20)
If Cells(r, a) = 0 Then GoTo 5
Cells(r, a) = Cells(r, a) - 1
GoTo 10
End Sub

 

[Muhammet Okumuş]

Toplu halde girmek için;

Sub Dağıt()
Application.ScreenUpdating = False

Dim a, r As Byte
For r = 2 To Cells(Rows.Count, 21).End(3).Row

If Range("U" & r) > 100 Or Range("U" & r) < 20 Or Not IsNumeric(Range("U" & r)) Then GoTo 20
Range("A" & r & ":T" & r) = 5
10
If WorksheetFunction.Sum(Range("A" & r & ":T" & r)) = Range("U" & r) Then GoTo 20
5
a = WorksheetFunction.RandBetween(1, 20)
If Cells(r, a) = 0 Then GoTo 5
Cells(r, a) = Cells(r, a) - 1
GoTo 10
20
Next
End Sub

 

[ozan_ismail]

Toplu halde girmek için;

Çok teşekkür ediyorum Muhammet bey

 

[xargrax]

Merhaba Hocam. ben bu kodu kullanmayı denedim. kod çalıştı. ancak u sutununa başka bir sayfadaki hücreden sayı çağırınca kod çalışmadı.

Birde bu rastgele dağıtılan sayılara belli hücrelerdeki sayıları üst sınır olarak belirlemek mümkün müdür?

 

[Muhammet Okumuş]

Ölçüt olarak belirtmeniz gerekir.