Sub Tafelindeling()
Dim Data, i As Integer, i1 As Integer, iTa As Integer, iSt As Integer, Loting, Dict As Object, arr(1 To 1, 1 To 4), iTafels As Integer, TafelStoel(), iDeelnemers As Integer, Tafels, Ten, Ten0, i2%, i3%, bOK As Boolean
Dim LO As ListObject
For Each LO In Sheets("indeling").ListObjects
LO.Range.AutoFilter
LO.ShowAutoFilter = True
Next
iDeelnemers = Range("Totaal_aantal_deelnemers").Value
If iDeelnemers <= 1 Then MsgBox "onvoldoende deelnemers om er een tabel van te maken": Exit Sub
iTafels = Range("Totaal_aantal_tafels_indelen").Value
ReDim Ten0(0 To 9): For i1 = 0 To UBound(Ten0): Ten0(i1) = Chr(i1 + 1): Next
Data = Range("tabel2") 'lees je namen in
Tafels = WorksheetFunction.Transpose(Range("tabel4").Resize(WorksheetFunction.Max(2, iTafels)))
ReDim Loting(1 To UBound(Data)) 'maak een array met even veel elementen als namen
ReDim TafelStoel(0 To 10, 0 To iTafels) 'array met in de rijen de stoelen en in de kolommen de tafels
Set Dict = CreateObject("scripting.dictionary") 'je dictionary aanmaken
With Dict 'in die dicitionary
For iSt = 0 To UBound(TafelStoel)
For iTa = 0 To UBound(TafelStoel, 2)
TafelStoel(iSt, iTa) = IIf(iTa > 0 And iSt > 0, "leeg", IIf(iTa > 0, "Tafel_" & Range("Tabel4").Cells(iTa, 1).Value, IIf(iSt > 0, "Stoel_" & iSt, "Tafelindeling"))) 'zet overal "leeg" in behalve in de 1e rij, daar de tafelnamen en de 1e kolom de stoelnrs
If iSt And iTa Then
arr(1, 1) = "leeg"
arr(1, 2) = "Tafel_" & Tafels(iTa) 'die zit aan deze tafel
arr(1, 4) = iTa
arr(1, 3) = iSt 'zijn stoel
.Item((iTa - 1) * 10 + iSt) = arr 'toevoegen aan dictionary
End If
Next
Next
Randomize 'random-getallen-generator
For i = 1 To UBound(Loting): Loting(i) = rnd: Next 'vul je array met random getallen
iTa = 1: iSt = 1 'start bij tafel1 en stoel1
For i = 1 To iDeelnemers 'zoveel keer als er namen zijn
arr(1, 2) = "Tafel_" & Tafels(iTa) 'die zit aan deze tafel
arr(1, 4) = iTa
arr(1, 3) = iSt 'zijn stoel
If i <= iDeelnemers Then
i1 = WorksheetFunction.Match(WorksheetFunction.Small(Loting, i), Loting, 0) 'plaats van de zoveelste kleinste in je loting = willekeurige naam uit je lijstje
arr(1, 1) = Data(i1, 1) & IIf(Len(Data(i1, 2)), " " & Data(i1, 2), "") & IIf(Len(Data(i1, 3)), " " & Data(i1, 3), "") 'zijn naam
Ten = Ten0
bOK = False
Randomize
Do
i2 = rnd * UBound(Ten)
i3 = Asc(Ten(i2))
If TafelStoel(i3, iTa) = "leeg" Then
arr(1, 3) = i3
TafelStoel(i3, iTa) = arr(1, 1)
.Item((iTa - 1) * 10 + i3) = arr
bOK = True
Else
Ten = Filter(Ten, Ten(i2), 0)
End If
Loop While Not bOK And UBound(Ten) <> -1
End If
iTa = iTa + 1 'tafel 1 ophogen
If iTa > iTafels Then iTa = 1: iSt = iSt + 1 'indien hoger dan aantal tafels, dan herbeginnen bij tafel1 en stoel 1 ophogen
Next
End With
Application.ScreenUpdating = False
With Range("Tabel3").ListObject 'uitvoertabel
If .ListRows.Count Then .DataBodyRange.Delete 'indien neit leeg dan leegmaken
If Dict.Count Then 'indien er namen zijn
.ListRows.Add.Range.Resize(Dict.Count, UBound(arr, 2)).Value = Application.Index(Dict.items, 0, 0) 'tabel aanvullen
With .DataBodyRange
.Sort .Range("D1"), key2:=.Range("C1"), Header:=True
End With
End If
End With
With Range("Tafel1_Stoel1") 'vanaf deze plaats
.Resize(1000, 10).ClearContents 'eerst ruim genoeg leegmaken
For i1 = 0 To (iTafels - 1) Step 5
For i = 1 To WorksheetFunction.Min(5, iTafels - i1)
.Offset((i1 \ 5) * (UBound(TafelStoel) + 5), (i - 1) * 2).Resize(1 + UBound(TafelStoel)).Value = Application.Index(TafelStoel, 0, 1) 'array wegschrijven
.Offset((i1 \ 5) * (UBound(TafelStoel) + 5), i * 2 - 1).Resize(1 + UBound(TafelStoel)).Value = Application.Index(TafelStoel, 0, i1 + i + 1) 'array wegschrijven
Next
Next
'.Resize(, 10).EntireColumn.AutoFit 'kolombreedte automatisch
End With
End Sub
