Yardım Nöbet Çizelgesi Oluşturmak

Sub NobetCizelgesiOlustur_V2()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets(1) ' İlk sayfada çalışacağımızı varsayıyorum
    
    Dim people(1 To 40) As String
    Dim tempPeople As Collection
    Dim i As Integer, j As Integer, k As Integer
    Dim dayCounter As Integer
    Dim person As String
    Dim week As Integer
    Dim twoWeeksPeople As Collection
    Dim availablePeople As Collection
    
    ' Kişilerin isimlerini oluştur
    For i = 1 To 40
        people(i) = "Person " & i
    Next i
    
    ' Başlıkları yazdır (Hafta ve Günler)
    ws.Cells(1, 1).Value = "Hafta"
    ws.Cells(1, 2).Value = "Gün"
    For i = 1 To 5
        ws.Cells(1, i + 2).Value = "Nöbetçi " & i
    Next i
    
    ' Gün isimleri ve haftalar
    Dim days(1 To 5) As String
    days(1) = "Pazartesi"
    days(2) = "Sali"
    days(3) = "Çarsamba"
    days(4) = "Persembe"
    days(5) = "Cuma"
    
    ' 2 hafta üst üste nöbet tutacak kişileri belirlemek için koleksiyon
    Set twoWeeksPeople = New Collection
    Set availablePeople = New Collection
    
    ' Mevcut 40 kişiyi koleksiyona ekleyelim
    For i = 1 To 40
        availablePeople.Add people(i)
    Next i
    
    ' 3 hafta için döngü
    dayCounter = 2 ' Veriler 2. satırdan başlayacak
    For week = 1 To 4
        For j = 1 To 5 ' Her hafta için 5 gün
            ' Gün başlıklarını yazdır
            ws.Cells(dayCounter, 1).Value = "Hafta " & week
            ws.Cells(dayCounter, 2).Value = days(j)
            
            ' Rastgele kişileri seç
            Set tempPeople = New Collection
            
            Do While tempPeople.Count < 5
                i = Application.WorksheetFunction.RandBetween(1, availablePeople.Count)
                person = availablePeople(i)
                
                ' 1. ve 2. haftada aynı 10 kişi 2 hafta üst üste nöbet tutacak
                If week = 1 Or week = 2 Then
                    If Not IsInCollection(twoWeeksPeople, person) Then
                        tempPeople.Add person
                        ' İlk 2 haftanın kişilerini kaydediyoruz
                        If week = 1 Then twoWeeksPeople.Add person
                    End If
                Else
                    ' 3. haftada, ilk iki hafta nöbet tutan 10 kişiyi yazmıyoruz
                    If Not IsInCollection(twoWeeksPeople, person) Then
                        tempPeople.Add person
                    End If
                End If
            Loop
            
            ' Seçilen kişileri yazdır
            For k = 1 To 5
                ws.Cells(dayCounter, k + 2).Value = tempPeople(k)
            Next k
            
            dayCounter = dayCounter + 1
        Next j
    Next week
End Sub

Function IsInCollection(coll As Collection, item As Variant) As Boolean
    Dim var As Variant
    On Error Resume Next
    var = coll(item)
    If Err.Number = 0 Then
        IsInCollection = True
    Else
        IsInCollection = False
    End If
    On Error GoTo 0
End Function