AW: Auslosung
21.12.2008 18:20:00
Daniel
Hi
nicht so ganz einfach, aber dieser Code sollte das Problem lösen:
Sub Auslosung()
Dim Calc As Long
Dim Anz As Long, AnzGrp As Long, AnzSp As Long
Dim i As Long, G As Long, S As Long
Dim Gruppen As Range
Dim ListeOrg
Calc = Application.Calculation
Application.Calculation = xlCalculationManual
Application.StatusBar = "Auslosung läuft"
'--- Spielerliste original sichern, allte Gruppeneinteilung löschen
ListeOrg = Range("A1").CurrentRegion.Value
Range("H1").CurrentRegion.ClearContents
Application.ScreenUpdating = False
'--- Gruppengrösse und Anzahl Spieler pro Gruppe ermitteln
AnzGrp = Range("F1").Value
AnzSp = WorksheetFunction.RoundUp((WorksheetFunction.CountA(Range("A:A")) - 1) / AnzGrp, 0)
'--- Gesetzte Spieler nach oben sortieren und benötigte Formeln einfügen
With Range("A1").CurrentRegion
.Sort key1:=Range("C2"), order1:=xlAscending
.Columns(3).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=RAND()+COUNTIF(aktGrp,RC[-1])"
End With
'--- Gruppen anlegen
For i = 1 To AnzGrp * 2 Step 2
With Range("H1").Offset(0, i - 1).Resize(, 2)
.Cells(1, 1).Value = "Gruppe " & (i + 1) / 2
.HorizontalAlignment = xlCenterAcrossSelection
.Font.Bold = True
End With
Next
'--- Spielernamen aus Liste in Gruppenfelder eintragen
Set Gruppen = Range("H2").Resize(AnzSp, AnzGrp * 2)
For S = 1 To AnzSp
For G = 1 To AnzGrp * 2 Step 2
If Range("C2").HasFormula Then
'--- Wenn nicht gesetzt, liste neu sortieren, Vereine, die in Gruppe schon _
vorhanden sind ans Ende
Application.Names.Add "aktGrp", Gruppen.Columns(G + 1)
Application.Calculate
Range("A1").CurrentRegion.Sort key1:=Range("C2"), order1:=xlAscending, header:= _
xlYes
End If
Gruppen(S, G).Value = Range("A2")
Gruppen(S, G + 1).Value = Range("B2")
Range("A2:C2").Delete shift:=xlUp
Next
Next
'--- Ursprungliche Spielerliste zurückschreiben
Range("A1").Resize(UBound(ListeOrg, 1), UBound(ListeOrg, 2)).Value = ListeOrg
'--- Vereinsspalte aus Gruppenliste löschen, Falls die Vereine angezeigt werden sollen
'--- diesen Codeabschnitt löschen oder auskommentieren
Gruppen.Rows(1).Offset(-1, 0).SpecialCells(xlCellTypeBlanks).EntireColumn.Delete
Gruppen(1).CurrentRegion.Rows(1).HorizontalAlignment = xlCenter
'--- Ursprüngliche Excel-Einstellungen wiederherstellen
Application.Calculation = Calc
Application.ScreenUpdating = True
Application.StatusBar = False
End Sub
damit es sicher funktioniert, sollte auch für jede Gruppe ein Spieler gesetzt werden, ansonsten könnte es doch vorkommen, daß mehrere Spieler aus dem gleichen Verein zusammentreffen.
das Makro ist an deine Beispieldatei angepasst und läuft ohne grössere Änderungen auch nur für diese Spaltenanordnung, auch die Leerspalten (z.B. D) müssen als solche erhalten bleiben.
Spieler, die in Spalte C einen beliebigen Wert haben, gelten als gesetzt, für ungesezte Spieler muss die Spalte C leer sein.
über die Vergabe der Zahlen 1-x für "Gesetzt", können die gesetzen Spieler bestimmten Gruppen zugeordnet werden.
Gruß, Daniel