AW: Gruppenauslosung erweitern VBA
29.03.2020 23:42:18
Barbara
Hi Fritz,
konnte es nicht lassen. Hier mein Code zu Deiner Gruppenauslosung.
Die Anzahl der Gruppen musst Du in C1 schreiben.
Die Anzahl der Freilose musst Du darunter in C2 schreiben.
Das kannst Du aber im Makro individuell einstellen.
Ebenso den Beginn der Mannschaftsliste und die Liste der Gruppen.
Sub Auslosung()
Dim rMannschaft1 As Range, rGruppe1 As Range
Dim lGruppen As Long, lSetz As Long, lMannschaften As Long
Dim i As Long, lZufall As Long, sZwischen As String
Set rMannschaft1 = Range("B2") 'Name der ersten Mannschaft
Set rGruppe1 = Range("F5") 'Zelle "Gruppe 1"
'Abfrage
lGruppen = Range("C1") 'Anzahl Gruppen
lSetz = Range("C2") 'Anzahl Setzmannschaften
Set rMannschaft1 = Range(rMannschaft1, Cells(Rows.Count, rMannschaft1.Column).End(xlUp)) _
lMannschaften = rMannschaft1.Rows.Count
Set rGruppe1 = rGruppe1.Resize(, lGruppen)
'Gruppenbereich und Randzellen rechts und darunger werden gelöscht
rGruppe1.Resize(rGruppe1(lMannschaften).Row - rGruppe1.Row + 3, lGruppen + 1).Clear
'Schreiben Gruppenüberschrift
For i = 1 To lGruppen
rGruppe1(i) = "Gruppe " & i
Next i
'Alle Mannschaften zu den Gruppen kopieren
Set rGruppe1 = rGruppe1.Offset(1)
For i = 1 To lMannschaften
rGruppe1(i) = rMannschaft1(i)
Next i
'Alle nicht gesetzten Mannschaften mischen
Randomize Timer
For i = lSetz + 1 To lMannschaften
lZufall = Int((lMannschaften - i + 1) * Rnd + i)
sZwischen = rGruppe1(i).Text
rGruppe1(i) = rGruppe1(lZufall)
rGruppe1(lZufall) = sZwischen
Next i
End Sub
LGB