Thema: Bedingte Formatierung

Hallo Profis
ich hab mir einen Lottoschein selbstgebastelt. Sieht fast so aus wie der Echte (Aber nur fast). Die Lottozahlen werden in den Bereichen:
Spiel1 CM4:CR4
Spiel2 CM6:CR6
Spiel3 CM8:CR8
Spiel4 CM10:CR10 usw.eingetragen.
Wie kann ich mit Bedingter Formatierung den Bereichen wo die Zahlen (1 - 49) stehen für Spiel1 B4:N16, Spiel2 B18:N30 so gestallten das das ein Kreutz gesetzt wird. Ich habe zwar da einen Code im Forum gefunden. Der klappt aber nur wenn in eine bestimmte Zelle ein Buchstabe gesetzt wird. Wie kann man ihn umstellen das die Bereiche bei einer Übereinstimmung mit einem Kreutz gesetzt werden.
Gruß Heiko

Private Sub Worksheet_Calculate()
'   diese Variante kostet natürlich Rechenleistung
'   da bei jeder Eingabe der Bereich Formatiert wird
'   Fülfarbe
'   für Schrift RaZelle.Font.ColorIndex
Dim RaBereich As Range, RaZelle As Range
' Bereich der Wirksamkeit
Set RaBereich = Range("B3:Y33,AD3:AZ33,BE3:CA33,C38:Y68,AD38:AZ68,BE38:CA68,C73:Y103,AD73: _
AZ103,BE73:CA103")
'   noch mehr Bereiche
'    Set RaBereich = Union(Range("C7:I26"), Range("L7:R26"), Range("U7:AA26"), Range("AD7:AJ26") _
)
'   ab Vesion XP braucht der Schutz nicht aufgehoben werden
'   Formatierung bei Schutz kann über Dialog Schutz eingestellt werden
For Each RaZelle In RaBereich
If Not Intersect(RaZelle, RaBereich) Is Nothing Then
Select Case RaZelle.Value
Case "F"
' hellgelb
RaZelle.Interior.ColorIndex = 36
Case "M"
' hellgrün
RaZelle.Interior.ColorIndex = 35
Case "N"
' helltürkis
RaZelle.Interior.ColorIndex = 34
Case Else
' Keine
RaZelle.Interior.ColorIndex = xlNone
End Select
End If
Next RaZelle
Set RaBereich = Nothing
End Sub

Hallo Heiko
ich kann leider keinen Zusammenhang zwischen dem Code und deinem Problem erkennen.
mit Bedingter Formatierung wird sich das nicht lösen lassen, da mit der Bedingten Formatierung in Excel XP keine Diagonalen Linien gesetzt werden können.
Falls eine Farbliche Markierung der Zellen ausreicht, könntest du es mit der bedingten Formatierung lösen.
die Formel wäre für Spiel 1:
=ZählenWenn($CM$4:$CR$4;B4)=1
falls du unbedingt Kreuze benötigst, muss man ein Makro schreiben, das die Rahmenlinien entsprechend setzt.
lad doch mal deine Datei hoch, damit man was ausprobieren kann.

Hi
hier ist die Tabelle. Die Zahlen die ich rechts eingebe sollen im Schein mit einem Kreutz Markiert werden. Weil sich die Zahlen öffters mal ändern.
Gruß Heiko
https://www.herber.de/bbs/user/53446.xls

Hallo Heiko
mal als Ansatz:
in etwa so:

Gruß Matthias

HI
sorry, aber ich würde es mit der Bedingten Formatierung machen und die angekreuzten Zellen mit Schwarzem Hintergrund und weisser Schrift (fett) markieren.
Das sieht besser aus als die Kreuze (oder willst du den Zettel zum einscannen verwenden )
Außerdem wirken Änderungen in den Zahlen sich sofort auf den Zettel aus, ohne das erst noch ein Makro gestartet werden muss.
https://www.herber.de/bbs/user/53449.xls
Gruß, Daniel

Hallo Leute
danke für eure hilfe.
Daniel das mit den Kreutzen würde mir besser gefallen. Gibt es dafür eine Lösung. Wäre sehr dankbar dafür.
Gruß Heiko

HI
das mit den Kreuzen geht nur als Makro, da die bedingte Formatierung in deiner Excelversion keine Diagonalen Rahmen kennt.
du könntest dieses Makro verwenden (muss ins Modul des Tabellenblatts)

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Zelle As Range
Dim Zahl As Range
Dim Spiel  As Range
Dim Tipp As Range
If Target.Column > Range("CR1").Column Then Exit Sub
If Target.Column < Range("CM1").Column Then Exit Sub
For Each Zelle In Target
If Cells(Zelle.Row, "CK").Value Like "Spiel*" Then
Set Spiel = Range(Cells(Zelle.Row, "CK").Value)
Set Tipp = Cells(Zelle.Row, "CM").Resize(1, 6)
For Each Zahl In Spiel
If IsNumeric(Zelle.Value) Then
Select Case WorksheetFunction.CountIf(Tipp, Zahl.Value)
Case 0
Zahl.Borders(xlDiagonalDown).LineStyle = xlNone
Zahl.Borders(xlDiagonalUp).LineStyle = xlNone
Case 1
With Zahl.Borders(xlDiagonalDown)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = 1
End With
With Zahl.Borders(xlDiagonalUp)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = 1
End With
Case Else
MsgBox "Tipp doppelt"
End Select
End If
Next
End If
Next
End Sub

folgende Vorarbeiten sind noch zu verrichten:
- jedem Spielfeld 1-49 musst du einem NAMEN zuweisen. Dieser Namen müssen immer mit "Spiel" beginnen, also z.B. "Spiel_1"
- dieser Name muss in der Spalte CK vor dem jeweiligen Tipp stehen
Gruß, Daniel

Hallo Daniel
habe es so gemacht wie du es gesagt hast aber es klappt nicht. Ich weis nicht was ich falsch gemacht haben soll. Hier noch einmal die Datei so wie ich es gemacht habe.
Gruß Heiko
https://www.herber.de/bbs/user/53522.xls

HI
nein, hast du nicht.
dashier hast du übersehen:

folgende Vorarbeiten sind noch zu verrichten:
- jedem Spielfeld 1-49 musst du einem NAMEN zuweisen. Dieser Namen müssen immer mit "Spiel"  _
beginnen, also z.B. "Spiel_1"
- dieser Name muss in der Spalte CK vor dem jeweiligen Tipp stehen

Gruß, Daniel

Hallo Daniel
hab jetzt in der Spalte CK so geändert wie du es gesagt hast. Spiel_1 - Spiel_12 aber es klappt immer noch nicht. Ich stehe vol auf dem Schlauch. Bitte bitte um hilfe.
Gruß Heiko

Ok Daniel
bin jetzt von dem Schlauch aufgestanden. Klappt alles super super Gud. Danke für deine tolle Hilfe.
Gruß Heiko :-)))

Hi Leute
habe doch noch was. Ich habe hier den Code mit dem ich wenn ich die Rechte Maustaste klicke die Zelle färbt. Wie stelle ich den Code um das das ganze mit einem Kreutz geht.
Gruß Heiko

Hi Leute
habe doch noch was. Ich habe hier den Code mit dem ich wenn ich die Rechte Maustaste klicke die Zelle färbt. Wie stelle ich den Code um das das ganze mit einem Kreutz geht.
Gruß Heiko
Der Code

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect([D2:AH2,D5:AF5,D8:AH8,D11:AG11,D14:AH14,D17:AG17,D20:AH20,D23:AH23,D26:AG26, _
D29:AH29,D32:AG32,D35:AH35], Target) Is Nothing Then
If Target.Interior.ColorIndex = 3 Then
Target.Interior.ColorIndex = x1None
Else
Target.Interior.ColorIndex = 3
End If
Cancel = True
End If
End Sub