Das sind die Codes auf den einzelnen Blättern.
Private Sub CommandButton1_Click()
' Rundenauslosung Makro
ActiveSheet.Unprotect "m"
Range("B7:B56").Copy
Range("AF7").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Dim zelle, str As String, strg As String
For Each zelle In Range("AF:AF")
If zelle.Value <> "" Then
str = str & zelle.AddressLocal(False, False) & ":"
End If
Next
strg = Left(str, Len(str) - 1)
Range(strg).Select
Dim Feld() As Integer ' Dynamisches Datenfeld deklarieren.
Anzahl = Selection.Cells.Count
von = Selection.Row
Spalte = Selection.Column
ReDim zahlen(Anzahl - 1, 1)
Randomize
'Zufallsreihenfolge
For i = 0 To Anzahl - 1
drin = True
Do Until drin = False
zahl = (Int(Rnd() * Anzahl))
drin = False
For j = 0 To i - 1
If zahl = zahlen(j, 1) Then drin = True
Next
Loop
zahlen(i, 1) = zahl
Next
'Zahlen einlesen
For z = 0 To Anzahl - 1
zahlen(z, 0) = Cells(von + z, Spalte)
Next
'Zahlen ausgeben
For z = 0 To Anzahl - 1
Cells(von + zahlen(z, 1), Spalte) = zahlen(z, 0)
Next
Range("AF7:AF56").Copy
Range("BP4").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
ReDim zahlen(Anzahl - 1, 1)
Randomize
'Zufallsreihenfolge
For i = 0 To Anzahl - 1
drin = True
Do Until drin = False
zahl = (Int(Rnd() * Anzahl))
drin = False
For j = 0 To i - 1
If zahl = zahlen(j, 1) Then drin = True
Next
Loop
zahlen(i, 1) = zahl
Next
'Zahlen einlesen
For z = 0 To Anzahl - 1
zahlen(z, 0) = Cells(von + z, Spalte)
Next
'Zahlen ausgeben
For z = 0 To Anzahl - 1
Cells(von + zahlen(z, 1), Spalte) = zahlen(z, 0)
Next
Range("AF7:AF56").Copy
Range("BR4").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
ReDim zahlen(Anzahl - 1, 1)
Randomize
'Zufallsreihenfolge
For i = 0 To Anzahl - 1
drin = True
Do Until drin = False
zahl = (Int(Rnd() * Anzahl))
drin = False
For j = 0 To i - 1
If zahl = zahlen(j, 1) Then drin = True
Next
Loop
zahlen(i, 1) = zahl
Next
'Zahlen einlesen
For z = 0 To Anzahl - 1
zahlen(z, 0) = Cells(von + z, Spalte)
Next
'Zahlen ausgeben
For z = 0 To Anzahl - 1
Cells(von + zahlen(z, 1), Spalte) = zahlen(z, 0)
Next
Range("AF7:AF56").Copy
Range("Bt4").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
ReDim zahlen(Anzahl - 1, 1)
Randomize
'Zufallsreihenfolge
For i = 0 To Anzahl - 1
drin = True
Do Until drin = False
zahl = (Int(Rnd() * Anzahl))
drin = False
For j = 0 To i - 1
If zahl = zahlen(j, 1) Then drin = True
Next
Loop
zahlen(i, 1) = zahl
Next
'Zahlen einlesen
For z = 0 To Anzahl - 1
zahlen(z, 0) = Cells(von + z, Spalte)
Next
'Zahlen ausgeben
For z = 0 To Anzahl - 1
Cells(von + zahlen(z, 1), Spalte) = zahlen(z, 0)
Next
Range("AF7:AF56").Copy
Range("Bv4").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
ReDim zahlen(Anzahl - 1, 1)
Randomize
'Zufallsreihenfolge
For i = 0 To Anzahl - 1
drin = True
Do Until drin = False
zahl = (Int(Rnd() * Anzahl))
drin = False
For j = 0 To i - 1
If zahl = zahlen(j, 1) Then drin = True
Next
Loop
zahlen(i, 1) = zahl
Next
'Zahlen einlesen
For z = 0 To Anzahl - 1
zahlen(z, 0) = Cells(von + z, Spalte)
Next
'Zahlen ausgeben
For z = 0 To Anzahl - 1
Cells(von + zahlen(z, 1), Spalte) = zahlen(z, 0)
Next
Range("AF7:AF56").Copy
Range("Bx4").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Anzahl = Range("B57")
anz = InputBox("Wie viele Paare dürfen pro Runde auf die Fläche?")
Range("BQ4:BQ" & (anz + 3)) = 1
Range("BQ" & (anz + 4) & ":BQ" & 2 * anz + 3) = 2
Range("BQ" & (2 * anz + 4) & ":BQ" & 3 * anz + 3) = 3
Range("BQ" & (3 * anz + 4) & ":BQ" & 4 * anz + 3) = 4
Range("BQ" & (4 * anz + 4) & ":BQ" & 5 * anz + 3) = 5
Range("BQ" & (5 * anz + 4) & ":BQ" & 6 * anz + 3) = 6
Range("BQ" & (6 * anz + 4) & ":BQ" & 7 * anz + 3) = 7
Range("BQ" & (7 * anz + 4) & ":BQ" & 8 * anz + 3) = 8
Range("BQ" & (8 * anz + 4) & ":BQ" & 9 * anz + 3) = 9
Range("BQ" & (9 * anz + 4) & ":BQ" & 10 * anz + 3) = 10
Range("BQ" & (10 * anz + 4) & ":BQ" & 11 * anz + 3) = 11
Range("BQ" & (11 * anz + 4) & ":BQ" & 12 * anz + 3) = 12
Range("BQ" & (12 * anz + 4) & ":BQ" & 13 * anz + 3) = 13
Range("BQ" & (13 * anz + 4) & ":BQ" & 14 * anz + 3) = 14
Range("BQ" & (14 * anz + 4) & ":BQ" & 15 * anz + 3) = 15
Range("BQ" & (15 * anz + 4) & ":BQ" & 16 * anz + 3) = 16
Range("BQ" & (16 * anz + 4) & ":BQ" & 17 * anz + 3) = 17
Range("BQ" & (17 * anz + 4) & ":BQ" & 18 * anz + 3) = 18
Range("BQ" & (18 * anz + 4) & ":BQ" & 19 * anz + 3) = 19
Range("BQ" & (19 * anz + 4) & ":BQ" & 20 * anz + 3) = 20
Range("BQ4:BQ60").Copy
Range("BS4").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Range("BQ4:BQ60").Copy
Range("BU4").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Range("BQ4:BQ60").Copy
Range("BW4").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Range("BQ4:BQ60").Copy
Range("BY4").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Range("BP4:BQ63").Sort Key1:=Range("BP4"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("BR4:BS63").Sort Key1:=Range("BR4"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("BT4:BU63").Sort Key1:=Range("BT4"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("BV4:BW63").Sort Key1:=Range("BV4"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("BX4:BY63").Sort Key1:=Range("BX4"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("BP4:BY63").Copy
Sheets("Vorrundenauslosung I").Unprotect "m"
Sheets("Vorrundenauslosung I").Range("A4").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Sheets("Vorrundenauslosung I").Protect "m"
Sheets("Vorrundenauslosung I").PrintOut Copies:=1, Collate:=True
ActiveSheet.Protect "m"
Exit Sub
errorhandler:
ActiveSheet.Protect "m"
End Sub
Private Sub CommandButton2_Click()
' Vorrunde Makro
Sheets("Auswertung Vorrunde").Select
End Sub
Private Sub CommandButton12_Click()
' LöschenVorrunde Makro
ActiveSheet.Unprotect "m"
Rows("4:56").Interior.ColorIndex = xlNone
Rows("4:4").EntireRow.Hidden = True
Range("E7:AC56,BN64:BN70").ClearContents
Sheets("Startliste").Unprotect "m"
Sheets("Startliste").Range("O10:P59").ClearContents
Sheets("Startliste").Protect "m"
Range("A7:C56").Sort Key1:=Range("A7"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("B7").Select
ActiveSheet.Protect "m"
End Sub
Private Sub CommandButton20_Click()
' Kreuzchensortierung Makro
ActiveSheet.Unprotect "m"
'alles zurücksetzen
Range("E4:BG56").Interior.ColorIndex = xlNone
Rows("4:4").EntireRow.Hidden = True
' 1. 5 Tänze
If Range("E60") = "1" Then
Range("E7:E56,E4").Select
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
Rows("4:4").EntireRow.Hidden = False
End If
If Range("f60") = "1" Then
Range("f7:f56,f4").Select
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
Rows("4:4").EntireRow.Hidden = False
End If
If Range("g60") = "1" Then
Range("g7:g56,g4").Select
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
Rows("4:4").EntireRow.Hidden = False
End If
If Range("h60") = "1" Then
Range("h7:h56,h4").Select
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
Rows("4:4").EntireRow.Hidden = False
End If
If Range("i60") = "1" Then
Range("i7:i56,i4").Select
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
Rows("4:4").EntireRow.Hidden = False
End If
' 2. 5 Tänze
If Range("j60") = "1" Then
Range("j7:j56,j4").Select
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
Rows("4:4").EntireRow.Hidden = False
End If
If Range("k60") = "1" Then
Range("k7:k56,k4").Select
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
Rows("4:4").EntireRow.Hidden = False
End If
If Range("l60") = "1" Then
Range("l7:l56,l4").Select
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
Rows("4:4").EntireRow.Hidden = False
End If
If Range("m60") = "1" Then
Range("m7:m56,m4").Select
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
Rows("4:4").EntireRow.Hidden = False
End If
If Range("n60") = "1" Then
Range("n7:n56,n4").Select
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
Rows("4:4").EntireRow.Hidden = False
End If
'3. 5 Tänze
If Range("o60") = "1" Then
Range("o7:o56,o4").Select
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
Rows("4:4").EntireRow.Hidden = False
End If
If Range("p60") = "1" Then
Range("p7:p56,p4").Select
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
Rows("4:4").EntireRow.Hidden = False
End If
If Range("q60") = "1" Then
Range("q7:q56,q4").Select
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
Rows("4:4").EntireRow.Hidden = False
End If
If Range("r60") = "1" Then
Range("r7:r56,r4").Select
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
Rows("4:4").EntireRow.Hidden = False
End If
If Range("s60") = "1" Then
Range("s7:s56,s4").Select
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
Rows("4:4").EntireRow.Hidden = False
End If
'4. 5 Tänze
If Range("t60") = "1" Then
Range("t7:t56,t4").Select
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
Rows("4:4").EntireRow.Hidden = False
End If
If Range("u60") = "1" Then
Range("u7:u56,u4").Select
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
Rows("4:4").EntireRow.Hidden = False
End If
If Range("v60") = "1" Then
Range("v7:v56,v4").Select
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
Rows("4:4").EntireRow.Hidden = False
End If
If Range("w60") = "1" Then
Range("w7:w56,w4").Select
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
Rows("4:4").EntireRow.Hidden = False
End If
If Range("x60") = "1" Then
Range("x7:x56,x4").Select
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
Rows("4:4").EntireRow.Hidden = False
End If
'5. 5 Tänze
If Range("y60") = "1" Then
Range("y7:y56,y4").Select
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
Rows("4:4").EntireRow.Hidden = False
End If
If Range("z60") = "1" Then
Range("z7:z56,z4").Select
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
Rows("4:4").EntireRow.Hidden = False
End If
If Range("aa60") = "1" Then
Range("aa7:aa56,aa4").Select
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
Rows("4:4").EntireRow.Hidden = False
End If
If Range("ab60") = "1" Then
Range("ab7:ab56,ab4").Select
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
Rows("4:4").EntireRow.Hidden = False
End If
If Range("ac60") = "1" Then
Range("ac7:ac56,ac4").Select
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
Rows("4:4").EntireRow.Hidden = False
End If
If Range("e67") <> "0" Then
Range("E4").Select
MsgBox ("Die Zahl der hier vergebenen Kreuze ist unzulässig!!!")
End If
Range("B7:AE56").Sort Key1:=Range("AE7"), Order1:=xlDescending, Header:=xlGuess _
, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("AE7").Select
ActiveSheet.Protect "m"
End Sub
Private Sub CommandButton3_Click()
' Zwischenrunde Makro
ActiveSheet.Unprotect "m"
Dim Anzahl As Integer
Dim anz As Long
Dim mind As Double
mind = WorksheetFunction.RoundUp(Range("A8"), 0)
Range("C57").Copy
Range("C57").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
mind = Range("C57")
With Sheets("Auswertung Vorrunde")
Anzahl = Application.InputBox("Wie viele Paare (mind. " & mind & ") sollen in die Zwischenrunde?", "Teilnehmer", 0, Type:=1)
If Anzahl = Empty Then Exit Sub
anz = Anzahl + 6
Range("B7:C" & anz).Copy
Range("BM7").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Selection.Sort Key1:=Range("BM7"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
End With
ActiveSheet.Protect "m"
Sheets("Auswertung Zwischenrunde").Select
End Sub
Private Sub CommandButton4_Click()
' Endrunde Makro
ActiveSheet.Unprotect "m"
Dim Anzahl As Integer
Dim anz As Long
With Sheets("Auswertung Vorrunde")
Anzahl = Application.InputBox("Wie viele Paare (max.7) sollen in die Endrunde?", "Teilnehmer", 0, Type:=1)
If Anzahl = Empty Then Exit Sub
anz = Anzahl + 6
Range("B7:B" & anz).Copy
Range("BN64").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Selection.Sort Key1:=Range("BN64"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
End With
ActiveSheet.Protect "m"
Sheets("Auswertung Endrunde").Select
End Sub
Private Sub CommandButton5_Click()
' Titelseite Makro
Sheets("Titelseite").Select
End Sub
So sehen alle Codes aus, die auf diesem Blatt zur Zeit laufen.
Nun wollte ich folgenden dazufügen, um auf der Seite in alle freigegebenen Zellen per Mausklick kreuze zu setzen:
Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
' erstellt von Hajo.Ziplies@web.de 12.11.02
' x in die Zelle
Dim RaBereich As Range
Set RaBereich = Range("E7:AC56")
If Intersect(Target, RaBereich) Is Nothing Then Exit Sub
' Abbruch, wenn Aktion nicht im Zielbereich
Application.EnableEvents = False
Cancel = True
If Target.Value = "x" Then
Target.Value = ""
Else
Target.Value = "x"
End If
Application.EnableEvents = True
Set RaBereich = Nothing
End Sub
Ist die Galskugel nun durchsichtiger geworden?
Ich unterschätze oft die Komplexität von Makros und VBA Codes.
Einiges, was einzeln läuft, muss in Verbindung mit anderen Sachen nicht auch so laufen.
Gruß Marcel