Excelde bir problem...

Sub RastgeleDagitCoklu()
Dim ws As Worksheet
Set ws = ActiveSheet

Dim n As Long: n = 10 ' satır sayısı (örnek: 10 kazanım)
Dim maxVal As Long: maxVal = 3 ' her hücredeki maksimum değer
Dim col As Long
Dim lastCol As Long

' Kaç sütunda çalışacağını belirle (örnek: B - K sütunları)
' Eğer 10 sütun istiyorsanız B=2, K=11 yani 2’den 11’e kadar
lastCol = 11

Dim target As Long
Dim vals() As Integer
Dim i As Long, count As Long

Randomize

' Her sütun için ayrı ayrı işle
For col = 2 To lastCol
' Hedef toplam bu sütunun 12. satırında
If Not IsNumeric(ws.Cells(12, col).Value) Then
ws.Cells(12, col).Interior.Color = vbYellow
ws.Cells(12, col).AddComment "Bu hücreye bir sayı girin (0-" & n * maxVal & ")."
GoTo NextColumn
End If

target = CLng(ws.Cells(12, col).Value)

' Geçerlilik kontrolü
If target < 0 Or target > n * maxVal Then
MsgBox ws.Cells(12, col).Address(False, False) & _
" hücresindeki hedef geçersiz. (0-" & n * maxVal & " arası olmalı.)", vbExclamation
GoTo NextColumn
End If

' Dizi oluştur
ReDim vals(1 To n)
For i = 1 To n
vals(i) = 0
Next i

count = 0

' Rastgele dağıtım
Do While count < target
Dim elig() As Long
Dim ecount As Long: ecount = 0

For i = 1 To n
If vals(i) < maxVal Then
ecount = ecount + 1
ReDim Preserve elig(1 To ecount)
elig(ecount) = i
End If
Next i

If ecount = 0 Then
MsgBox "Sınırlar doldu; " & ws.Cells(12, col).Address(False, False) & _
" toplamı dağıtılamıyor.", vbCritical
GoTo NextColumn
End If

Dim rndIndex As Long
rndIndex = elig(Int(Rnd * ecount) + 1)
vals(rndIndex) = vals(rndIndex) + 1
count = count + 1
Loop

' Sonuçları yaz (örneğin B2:B11, C2:C11 …)
For i = 1 To n
ws.Cells(i + 1, col).Value = vals(i)
Next i

NextColumn:
Next col

MsgBox "Dağıtım tamamlandı!", vbInformation
End Sub

Genişletmek için tıkla ...

seloman2023' Alıntı:

mantık hatası var hocam sanki. toplam not en az 1 en fazla 10 demişsiniz ancak 10 dan küçük girilirse dağıtımda hata olur. min 10 girilmesi gerekir. yada sıfır yazılabilmeli hücrelere.

Genişletmek için tıkla ...

GezginN61' Alıntı:

Örneği kendi çalışmana uyarlayabilirsin. (Kodu yapay zekaya yazdırdım. Test ettim. Gayet stabil çalışıyor.)

Genişletmek için tıkla ...

ahmetyuksel' Alıntı:

Ekli dosyayı görüntüle 80504

cevapladığınız için teşekkürler. yalnız şöyle bir hata var puan dağılımı 1-3 arasında olması gerekirken "0"sıfırda atamış bunu nasıl düzeltebiliriz

Genişletmek için tıkla ...