AW: Spieler Auslosung (mit Freilose)
10.04.2005 11:08:58
WernerB.
Hallo Dan,
da mir Dein Tabellenblatt nicht vorliegt, gelten für meinen Makrovorschlag folgende Voraussetzungen:
1. Die Spielernamen stehen lückenlos(!) im Zellbereich A1:A32; d.h., bei weniger als 32 Teilnehmern bleiben die letzten Zellen entsprechend ohne Inhalt.
2. Die von Dir vorgegebenen Zufallszahlen stehen im Zellbereich B1:B32.
3. Die Position(!) der Freilose steht im Zellbereich C1:C32; es muss gewährleistet sein, dass hier die Anzahl der Einträge ausreichend groß ist.
Wenn meine Annahmen nicht zutreffen, muss das Makro natürlich noch entsprechend angepasst werden.
Solltest Du dazu nicht selbst in der Lage sein, kannst Du Deine Datei (bitte nur ohne Makros!) hier hochladen; ich versuche dann ggf. die Anpassung für Dich vorzunehmen.
Sub Dan()
Dim laR As Long, _
anzTe As Byte, anzFr As Byte, BlaIn As Byte, i As Byte
Application.ScreenUpdating = False
laR = Cells(Rows.Count, 1).End(xlUp).Row
If laR > 32 Then
MsgBox "Zu viele Teilnehmer gelistet !" & vbCr & vbCr & _
"Makro-Abbruch !", vbOKOnly + vbCritical, _
"Dezenter Hinweis für " & Application.UserName & ":"
Exit Sub
End If
BlaIn = ActiveSheet.Index
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Range("A1:C32").Value = _
Sheets(BlaIn).Range("A1:C32").Value
Range("A1:B" & laR).Sort Key1:=Range("B1"), _
Order1:=xlAscending, Header:=xlNo, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
If laR < 32 Then
Range("D1").Value = 1
Range("D1").AutoFill Destination:=Range("D1:D32"), _
Type:=xlFillSeries
anzTe = laR
anzFr = 32 - laR
Range("C1:C" & anzFr).Sort Key1:=Range("C1"), _
Order1:=xlAscending, Header:=xlNo, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
For i = 1 To anzFr
Cells(Range("C" & i).Value, 4).ClearContents
Next i
Range("D1:D32").Sort Key1:=Range("D1"), _
Order1:=xlAscending, Header:=xlNo, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
Range(Cells(anzTe + 1, 4), Cells(32, 4)).Value = _
Range("C1:C" & anzFr).Value
Range("B1:B32").Value = Range("D1:D32").Value
Range("A1:B32").Sort Key1:=Range("B1"), _
Order1:=xlAscending, Header:=xlNo, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
End If
Sheets(BlaIn).Range("A1:A32").Value = _
ActiveSheet.Range("A1:A32").Value
Application.DisplayAlerts = False
Sheets(Sheets.Count).Delete
Application.DisplayAlerts = True
Sheets(BlaIn).Select
Application.ScreenUpdating = True
End Sub
Viel Erfolg wünscht
WernerB.
P.S.: Dieses Forum lebt auch von den Rückmeldungen der Fragesteller an die Antworter !