AW. zu MichaV
04.05.2005 12:04:27
Thomas
Hallo Micha!
Die Idee mit der Email an Hajo geht leider ins Leere, da er extra darauf hinweist, keine Emails erhalten zu wollen, da alle Probleme im Forum gelöst werden sollen. Deshalb hier zunächst der aus meiner Sicht relevante Code (Hajo's Originalcode in voller Länge steht weiter unten):
Dim BoAktion As Boolean
Dim InOldColorIndex As Integer
Dim StOldRange As String
Dim StRegister As String
Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
If BoAktion = True Then Exit Sub
If TypeName(ActiveSheet) = "Worksheet" Then
With Worksheets(StRegister) DIESE ZEILE WIRD ALS FEHLERQUELLE INDENTIFIZIERT!!
If StOldRange <> "" Then .Range(StOldRange).Interior.ColorIndex = InOldColorIndex
End With
End If
End Sub
Noch eine Anmerkung: Hajo's Beispieldatei verfügt nicht wie meine über vier, sondern nur über zwei Arbeitsblätter. Aufgrund des Fehlerhinweise drängt sich mir der Eindruck auf, dass das Problem in der unterschiedlichen Anzahl der Arbeitsblätter liegt. Allerdings kann ich nicht erkennen, dass Hajo die Anzahl der Blätter vorgegeben hat. Wie dem auch sei, hier Hajo's Originalcode:
DIESE ARBEITSMAPPE
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
Gruß
Thomas