Option Explicit ' Variablendefinition erforderlich
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
' Liste 1: (A:F); Liste 2: (H:M); Liste 3: (O:T)
'***********************************************
'* H. Ziplies *
'* 14.09.14 *
'* erstellt von HajoZiplies@web.de Spam *
'*
http://Hajo-Excel.de/ *
'***********************************************
Dim RaBereich As Range ' Variable für Bereich
Dim RaZelle As Range ' Variable für Zelle
Dim dblCount As Double
dblCount = CallByName(Selection, IIf(Val( _
Application.Version) > 11, "CountLarge", "Count"), VbGet)
' von Nepumuk
If dblCount = 1 Then
' nur bei Auswahl einer Zelle
Range("A:F").Interior.ColorIndex = xlNone ' Farbe Löschen
Range("H:M").Interior.ColorIndex = xlNone ' Farbe Löschen
Range("O:T").Interior.ColorIndex = xlNone ' Farbe Löschen
Set RaBereich = Range("A:F") ' Bereich der Wirksamkeit 1. Bereich
Set RaBereich = Intersect(RaBereich, Range(Target.Address))
If Not RaBereich Is Nothing Then
'ActiveSheet.Unprotect ("Passwort")
Range(Cells(Target.Row, 1), Cells(Target.Row, 6)).Interior.Color = 65535
'ActiveSheet.protect ("Passwort")
Else
Set RaBereich = Range("H:M") ' Bereich der Wirksamkeit 2. Bereich
Set RaBereich = Intersect(RaBereich, Range(Target.Address))
If Not RaBereich Is Nothing Then
'ActiveSheet.Unprotect ("Passwort")
Range(Cells(Target.Row, 8), Cells(Target.Row, 13)).Interior.Color = 65535
'ActiveSheet.protect ("Passwort")
Else
Set RaBereich = Range("O:T") ' Bereich der Wirksamkeit 3. Bereich
Set RaBereich = Intersect(RaBereich, Range(Target.Address))
If Not RaBereich Is Nothing Then
'ActiveSheet.Unprotect ("Passwort")
Range(Cells(Target.Row, 15), Cells(Target.Row, 20)).Interior.Color = 65535
'ActiveSheet.protect ("Passwort")
End If
End If
End If
Set RaBereich = Nothing ' Variable leeren
End If
End Sub