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 ...