Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
328to332
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
328to332
328to332
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Frage an Hajo_Zi

Frage an Hajo_Zi
25.10.2003 18:17:14
Marcel
Hallo, Du hast mir schon öfter erfolgreich geholfen. Ich habe aus Deinen Beispielen die Datei "x" oder Kreuze in Zellen eintragen gefunden.
Leider funktioniert das nicht bei mir. Ich habe eine Datei mit vielen VBAs. Nun habe ich keine Ahnung, woran das liegt.

8
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Kreuz in Zelle
25.10.2003 18:39:32
Hajo_Zi
Hallo Marcel

meine Datei einzeln geht doch??? Da ich es auch unter XP getestet habe.

1. die meisten haben hier keine Glaskugel
2. die meisten haben kleinen Heiligenschein
3. die meisten können nicht auf Deinen Rechner schauen

für alle diese Leute ist die Antwort schneller erstellt, wenn Du den relevanten Code postest.

Bitte keine Mail, Probleme sollten im Forum gelöst werden.

Microsoft MVP für Excel

Das Forum lebt auch von den Rückmeldungen.


Anzeige
AW: Kreuz in Zelle
25.10.2003 20:45:41
Marcel
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
Anzeige
AW: Kreuz in Zelle
25.10.2003 20:53:59
Hajo_Zi
Hallo Marcel

bei code sprach ich von einigen Zeilen, bei so umfangreichen Code wäre es schon besser die Datei hochzuladen. Wer soll das nachbauen???

Bitte keine Mail, Probleme sollten im Forum gelöst werden.

Microsoft MVP für Excel

Das Forum lebt auch von den Rückmeldungen.


AW: Kreuz in Zelle
25.10.2003 21:00:54
Marcel
die Datei ist 3,2 MB gross. Geht das?
AW: Kreuz in Zelle
25.10.2003 21:10:04
Hajo_Zi
Hallo Marcel

ich habe noch nicht getestet wie groß Datein sein dürfen. Aber bedenke doch auch mal wer soll das runterladen der kein Flatrate hat. Ich würde doch schon mal nur den relevanten Teil posten und diese Zippen.

Ich Vermute mal Du hast für den CommandButton nicht die Symbolleiste Steuerelemente Toolbox eingesetzt.

Ich sehe auch Du hast meinen Code aus Tabelle2 unverändert eingesetzt und ich hoffe mal das Du ihn unter die Tabelle kopiert hast wie im Beispiel.

Bitte keine Mail, Probleme sollten im Forum gelöst werden.

Microsoft MVP für Excel

Das Forum lebt auch von den Rückmeldungen.


Anzeige
AW: Kreuz in Zelle
25.10.2003 21:32:58
Marcel
https://www.herber.de/bbs/user/1590.zip
Hier ist die Datei in verkleinerter Version.
Ich will verdammt sein, aber in dieser Datei geht das mit den Kreuzen. Aber in meiner Originaldatei (ich habe nur alle doppelten Blätter gelöscht) läuft das nicht.
Habe ich bestimmt einen grausamen Anfängerfehler gemacht.
Alle Blätter Mit den Runden gibt es 4 mal in der Datei.
Hoffentlich gehe ich nicht zu stark auf die Nerven.
Gruß Marcel
AW: Kreuz in Zelle
25.10.2003 21:45:49
Hajo_Zi
Hallo Marcel

wenn es in der Datei geht, wie soll ich den Fehler finden.

Mann sollte hochgeladene Datei nicht schützen und auch nicht die Register.

Schicke mir mal die gepackte Original Datei an meine Email, Adresse steht auf der Homepage. Ich sehe mir mal das morgen an.

Bitte keine Mail, Probleme sollten im Forum gelöst werden.

Microsoft MVP für Excel

Das Forum lebt auch von den Rückmeldungen.


Anzeige
AW: Kreuz in Zelle
26.10.2003 10:27:37
Hajo_Zi
Hallo

für alle die die Lösung wissen möchten.

Marcel hatte den Code nicht in der Tabelle, Einige Prozeduren waren Doppelt und bei Option Explicit waren einige Variablen nicht definiert

Bitte keine Mail, Probleme sollten im Forum gelöst werden.

Microsoft MVP für Excel

Das Forum lebt auch von den Rückmeldungen.


Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige