AW: farbliche Darstellung eines Feldes
28.09.2004 13:25:33
Klaus
Hier der Code aus dem Forum, den ich benutzen möchte:
Frage noch dazu, wie wird er in eine xls/xlt-Datei benutzt/eingefügt?
Option Explicit
' erstell von Hajo.Ziplies@web.de 14.12.02
' http://home.media-n.de/ziplies/
' Korrektur 07.06.03, Kommentar, Definition
' der Code ist nur für eine Zelle vorgesehen
' sollten mehere Zellen markiert werden erfolgt kein Markierung
' die letzte Farbe wird erst zurückgesetzt, wenn nur eine Zelle markiert
' Farbformatierungen während der Selektion bleiben erhalten, außer rot
' Abschalten durch Doppelklick
Dim BoAktion As Boolean
Dim InOldColorIndex As Integer
Dim StOldRange As String
Dim StRegister As String
Private Sub Workbook_Open()
' nach Hinweis von Peter Haserodt Vergleich eingefügt
If TypeName(ActiveSheet) = "Worksheet" Then
StOldRange = ActiveCell.Address
StRegister = ActiveSheet.Name
InOldColorIndex = ActiveCell.Interior.ColorIndex
' Unprotect "Test"
ActiveCell.Interior.ColorIndex = 3
' Protect "Test"
End If
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
If BoAktion = True Then Exit Sub
If Target.Count > 1 Then Exit Sub
' nach Hinweis von Peter Haserodt Vergleich eingefügt
If TypeName(ActiveSheet) = "Worksheet" Then
With ActiveSheet
' .Unprotect "Test"
' Falls beim öffnen keine Tabelle aktiv ist StOldRange noch undefiniert
If StOldRange = "" Then
StOldRange = Target.Address
InOldColorIndex = Target.Interior.ColorIndex
' Setze Hintergrundfarbe der aktiven Selection auf Rot
Target.Interior.ColorIndex = 3
Else
' Setze alten Range auf alte Farbe
If Range(StOldRange).Interior.ColorIndex = 3 Then
Range(StOldRange).Interior.ColorIndex = InOldColorIndex
End If
InOldColorIndex = Target.Interior.ColorIndex
' Merke mir aktuellen Adresse für nächsten Aufruf
StOldRange = Target.Address
' Setze Hintergrundfarbe der aktiven Selection auf Rot
Target.Interior.ColorIndex = 3
End If
' .Protect "Test"
End With
End If
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
If BoAktion = True Then Exit Sub
' nach Hinweis von Peter Haserodt Vergleich eingefügt
If TypeName(ActiveSheet) = "Worksheet" Then
With ActiveSheet
' .Unprotect "Test"
If StOldRange <> "" Then .Range(StOldRange).Interior.ColorIndex = InOldColorIndex
' .Protect "Test"
End With
End If
End Sub
Private Sub Workbook_BeforePrint(Cancel As Boolean)
' falls Farbe beim Druck wieder zurückgestellt werden soll
' nach Druck ist die aktuelle Zelle nicht markiert
If BoAktion = True Then Exit Sub
' nach Hinweis von Peter Haserodt Vergleich eingefügt
If TypeName(ActiveSheet) = "Worksheet" Then
With ActiveSheet
' .Unprotect "Test"
If StOldRange <> "" Then .Range(StOldRange).Interior.ColorIndex = InOldColorIndex
' .Protect "Test"
End With
End If
End Sub
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
BoAktion = False
' nach Hinweis von Peter Haserodt Vergleich eingefügt
If TypeName(ActiveSheet) = "Worksheet" Then
StOldRange = ActiveCell.Address
InOldColorIndex = ActiveCell.Interior.ColorIndex
With ActiveSheet
' .Unprotect "Test"
ActiveCell.Interior.ColorIndex = 3
' .Protect "Test"
End With
StRegister = ActiveSheet.Name
End If
End Sub
Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
If BoAktion = True Then Exit Sub
' nach Hinweis von Peter Haserodt Vergleich eingefügt
If TypeName(ActiveSheet) = "Worksheet" Then
With Worksheets(StRegister)
' .Unprotect "Test"
If StOldRange <> "" Then .Range(StOldRange).Interior.ColorIndex = InOldColorIndex
' .Protect "Test"
End With
End If
End Sub
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
BoAktion = Not BoAktion
If BoAktion = True Then
' nach Hinweis von Peter Haserodt Vergleich eingefügt
If TypeName(ActiveSheet) = "Worksheet" Then
With Worksheets(StRegister)
' .Unprotect "Test"
If StOldRange <> "" Then .Range(StOldRange).Interior.ColorIndex = InOldColorIndex
' .Protect "Test"
End With
End If
Else
If TypeName(ActiveSheet) = "Worksheet" Then
With ActiveSheet
' .Unprotect "Test"
' Falls beim öffnen keine Tabelle aktiv ist StOldRange noch undefiniert
If StOldRange = "" Then
StOldRange = Target.Address
InOldColorIndex = Target.Interior.ColorIndex
' Setze Hintergrundfarbe der aktiven Selection auf Rot
Target.Interior.ColorIndex = 3
Else
' Setze alten Range auf alte Farbe
If Range(StOldRange).Interior.ColorIndex = 3 Then
Range(StOldRange).Interior.ColorIndex = InOldColorIndex
End If
InOldColorIndex = Target.Interior.ColorIndex
' Merke mir aktuellen Adresse für nächsten Aufruf
StOldRange = Target.Address
' Setze Hintergrundfarbe der aktiven Selection auf Rot
Target.Interior.ColorIndex = 3
End If
' .Protect "Test"
End With
End If
End If
Cancel = True
End Sub