aşağıdaki kod cüzü dağıtmak için ama şöyle bir sorun vardı: dağıtmaya 1'den başlayınca sırayla gittiği için bazen 29 ve 30 gibi sonlardaki cüzler, kişi aynı cüzleri alamayacağı için dağıtılmıyordu. o nedenle cüz dağıtma sıralamasını rasgele ayarlamaya çalıştım ama raslantısallık'tan kaynaklanan sebepler yine de sona kalanların yine yukardaki akıbete uğrama ihtimali var. bunu engellemek için dağıtımdan sonra -cüz eklenebileceği halde- eklenmemiş kalan cüzleri dağıtmak için 5 defaya kadar dağıtma döngüsü tekrar çalışıyor ama maalesef kesin garanti veremiyorum
Public Sub CuzDagitFonk()
Dim sht As Worksheet
Set sht = Sayfa1
Sonstr = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
'TamCuz = ",1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,"
For HaftaSay = 1 To 8
HaftaCuz = TamCuzFnk
If sht.Cells(1, HaftaSay * 3 + 1).Value = 1 Then
Bastan:
tekSay = 0
sht.Range(Cells(2, HaftaSay * 3), Cells(Sonstr, HaftaSay * 3 + 1)).ClearContents
For x = 2 To Sonstr
KisiCuz = ""
Set Rng = sht.Range("A" & x)
If HucreGetir(Rng) = True And (Not IsNull(Rng.Offset(0, 1)) And Rng.Offset(0, 1) <> "") Then
CSy = Rng.Offset(0, 1).Value
TmpKisiCuz = sht.Range("C" & x) & "," & sht.Range("I" & x) & "," & sht.Range("L" & x) & "," & sht.Range("O" & x) & "," & _
sht.Range("R" & x) & "," & sht.Range("U" & x) & "," & sht.Range("X" & x)
TmpDizi = Split(TmpKisiCuz, ",")
TmpHaftaCuz = HaftaCuz
For Each Item In TmpDizi
If Item <> "" Then TmpHaftaCuz = Replace(TmpHaftaCuz, "," & Item & ",", ",")
Next Item
For CzSay = 1 To CSy
CuzSil = Split(TmpHaftaCuz, ",")(1)
If CuzSil = "" Then
sht.Cells(x, HaftaSay * 3).Value = Mid(KisiCuz, 2)
GoTo SonrakiHafta '10
End If
KisiCuz = KisiCuz & "," & CuzSil
HaftaCuz = Replace(HaftaCuz, "," & CuzSil & ",", ",")
TmpHaftaCuz = Replace(TmpHaftaCuz, "," & CuzSil & ",", ",")
Next CzSay
sht.Cells(x, HaftaSay * 3).Value = Mid(KisiCuz, 2)
End If
Next x
If Len(Replace(HaftaCuz, ",", "") & "") > 0 Then
tekSay = tekSay + 1
If tekSay = 6 Then GoTo SonrakiHafta
GoTo Bastan
End If
End If
SonrakiHafta:
10
Next HaftaSay
End Sub
Function HucreGetir(ByVal Rng As Range) As Boolean
Dim cb As CheckBox
For Each cb In Sayfa1.CheckBoxes
If cb.TopLeftCell.Address = Rng.Address Then HucreGetir = cb.Value
Next cb
End Function
Function TamCuzFnk() As String
Dim x() As Variant
x = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30)
x = Resample(x)
TamCuzFnk = "," & Join(x, ",") & ","
End Function
Function Resample(data_vector() As Variant) As Variant()
Dim shuffled_vector() As Variant
shuffled_vector = data_vector
Dim i As Long
For i = UBound(shuffled_vector) To LBound(shuffled_vector) Step -1
Dim t As Variant
t = shuffled_vector(i)
Dim j As Long
j = Application.RandBetween(LBound(shuffled_vector), UBound(shuffled_vector))
shuffled_vector(i) = shuffled_vector(j)
shuffled_vector(j) = t
Next i
Resample = shuffled_vector
End Function
