Hallo markchili...
hab mal ein wenig 'Vitaburlecitin Geistlich' getankt.... und schon fertig :-)
Alsooo, es gibt 3 Tabellen:
Das erste Blatt hast Du schon.. mit der Spielplangenerierung.
Auf dem DRITTEN Blatt sind die Namen hinterlegt:
In Spalte A ab Zeile 11 stehen die fortlaufenden Nummer der Teilnehmer
In Spalte B werden die Namen eingetragen.
In das ZWEITE Blatt kommt der folgende Code
Option Explicit
Dim i As Integer
Dim AnzStuehle As Integer
Dim AnzTische As Integer
Dim Reihe As Integer
Dim j As Integer
Dim k As Integer
Dim T As Integer
Dim tt As Integer
' Tabelle1 ist das Blatt, auf dem der Spielplan entworfen wird
' Tabelle3 ist das Blatt, auf dem den Nummern die Namen zugeordnet sind
' Tabelle2 ist dieses Blatt
' Da mit diesem Code auf die beiden anderen zugegriffen wird,
' ist es wichtig, das die Reihenfolge der Blätter stimmt.
' Es wird mit dem Index <Sheets(1)> gearbeitet!
Private Sub CommandButton1_Click()
' ------------ Spaltenbreiten ---------------
For i = 0 To 5
ActiveSheet.Columns(i * 3 + 1).ColumnWidth = 1
ActiveSheet.Columns(i * 3 + 2).ColumnWidth = 8
ActiveSheet.Columns(i * 3 + 3).ColumnWidth = 8
Next i
' ----------- Kärtchen löschen ----------------
ActiveSheet.Columns("A:P").ClearContents
ActiveSheet.Columns("A:P").Borders(xlDiagonalDown).LineStyle = xlNone
ActiveSheet.Columns("A:P").Borders(xlDiagonalUp).LineStyle = xlNone
ActiveSheet.Columns("A:P").Borders(xlEdgeLeft).LineStyle = xlNone
ActiveSheet.Columns("A:P").Borders(xlEdgeTop).LineStyle = xlNone
ActiveSheet.Columns("A:P").Borders(xlEdgeBottom).LineStyle = xlNone
ActiveSheet.Columns("A:P").Borders(xlEdgeRight).LineStyle = xlNone
ActiveSheet.Columns("A:P").Borders(xlInsideVertical).LineStyle = xlNone
ActiveSheet.Columns("A:P").Borders(xlInsideHorizontal).LineStyle = xlNone
' -------------------------------------------------
AnzStuehle = Sheets("Tabelle1").Cells(3, 1)
AnzTische = Sheets("Tabelle1").Cells(3, 8)
' -------------- Karten generieren ----------------------
Reihe = 0: T = 0
If (AnzTische * AnzStuehle) Mod 5 <> 0 Then T = 1
For i = 0 To (Int((AnzTische * AnzStuehle) / 5)) - 1 + T
For j = 0 To 4
ActiveSheet.Range(Cells(11 + Reihe * (AnzTische + 4), 2 + j * 3), Cells(13 + AnzTische + Reihe * (AnzTische + 4), 3 + j * 3)).Borders(xlEdgeLeft).Weight = xlThick
ActiveSheet.Range(Cells(11 + Reihe * (AnzTische + 4), 2 + j * 3), Cells(13 + AnzTische + Reihe * (AnzTische + 4), 3 + j * 3)).Borders(xlEdgeTop).Weight = xlThick
ActiveSheet.Range(Cells(11 + Reihe * (AnzTische + 4), 2 + j * 3), Cells(13 + AnzTische + Reihe * (AnzTische + 4), 3 + j * 3)).Borders(xlEdgeBottom).Weight = xlThick
ActiveSheet.Range(Cells(11 + Reihe * (AnzTische + 4), 2 + j * 3), Cells(13 + AnzTische + Reihe * (AnzTische + 4), 3 + j * 3)).Borders(xlEdgeRight).Weight = xlThick
ActiveSheet.Range(Cells(13 + Reihe * (AnzTische + 4), 2 + j * 3), Cells(13 + AnzTische + Reihe * (AnzTische + 4), 3 + j * 3)).Borders(xlInsideVertical).Weight = xlThin
ActiveSheet.Range(Cells(13 + Reihe * (AnzTische + 4), 2 + j * 3), Cells(14 + Reihe * (AnzTische + 4), 3 + j * 3)).Borders(xlInsideHorizontal).Weight = xlThin
ActiveSheet.Cells(13 + Reihe * (AnzTische + 4), 2 + j * 3) = "In Runde:"
ActiveSheet.Cells(13 + Reihe * (AnzTische + 4), 3 + j * 3) = "An Tisch:"
For k = 1 To AnzTische
ActiveSheet.Cells(13 + Reihe * (AnzTische + 4) + k, 2 + j * 3) = k
Next k
Next j
Reihe = Reihe + 1
Next i
' ------------------ Namen eintragen -----------------
T = 1: Reihe = 0
Do
ActiveSheet.Cells(11 + Reihe * (AnzTische + 4), (T Mod 6) * 3 - 1) = Sheets(3).Cells(10 + T + Reihe * 5, 2)
T = T + 1
If T Mod 6 = 0 Then
Reihe = Reihe + 1
T = 1
End If
Loop While T + Reihe * 5 < AnzStuehle * AnzTische + 1
' --------- Tischnummern zuordnen ----------------
For k = 0 To AnzTische - 1 '------Schleife Runden
For i = 1 To AnzTische '--------Schleife Tische
For j = 1 To AnzStuehle ' Schleife Stühle
T = Sheets(1).Cells(10 + j, 1 + i + k * AnzTische)
Reihe = 0: tt = T
Do While tt > 5
tt = tt - 5
Reihe = Reihe + 1
Loop
ActiveSheet.Cells(14 + Reihe * (AnzTische + 4) + k, tt * 3) = i
Next j
Next i
Next k
End Sub
Ich hab nur Stichpunktartig kontrolliert, und hoffe es ist alles richtig auf den Karten.
Achja... den Code in Blatt1 kannst Du noch erweitern:
Füge die Zeilen zwischen den Rautenzeilen noch ein.
Damit werden auf Blatt3 die aktuellen Teilnehmernummern eingetragen.
(Namen bleiben)
ActiveSheet.Cells(1, 1) = AnzStuehle
ActiveSheet.Cells(1, 8) = AnzTische
'############# Ergänzung Teilnehmernummern auf Blatt 3 #############
Sheets(3).Columns("A:A").ClearContents
Sheets(3).Cells(10, 1) = "Nr."
For i = 1 To AnzStuehle * AnzTische
Sheets(3).Cells(10 + i, 1) = i
Next i
'################################################
End Sub
Schau's Dir an...
Viel Spassss beim Kontrollieren :-)
Gruß
Kauz
