title image


Smiley Re: Bei Activer Zelle, Zelle einfärben
Hallo ???



siehe mal meine Microseite.



für alle Zellen







' **************************************************************

' Modul: DieseArbeitsmappe Typ = Element der Mappe(Sheet, Workbook, ...)

' **************************************************************



Option Explicit

' erstell von Hajo.Ziplies@web.de 14.12.02

' der Code ist nur für eine Zelle vorgesehen

' sollten mehere Zellen markiert werden geht die Farbformatierung verloren

' Farbformatierungen während der Selektion bleiben erhalten, außer rot

' Abschalten durch Doppelklick

Dim Aktion As Boolean



Private Sub Workbook_BeforeClose(Cancel As Boolean)

' nach Hinweis von Peter Hasserodt Vergleich eingefügt

If Aktion = True Then Exit Sub

If TypeName(ActiveSheet) = "Worksheet" Then

With ActiveSheet

' .Unprotect "Test"

If OldRange <> "" Then .Range(OldRange).Interior.ColorIndex = OldColorIndex

' .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

' nach Hinweis von Peter Hasserodt Vergleich eingefügt

If Aktion = True Then Exit Sub

If TypeName(ActiveSheet) = "Worksheet" Then

With ActiveSheet

' .Unprotect "Test"

If OldRange <> "" Then .Range(OldRange).Interior.ColorIndex = OldColorIndex

' .Protect "Test"

End With

End If

End Sub



Private Sub Workbook_Open()

' nach Hinweis von Peter Hasserodt Vergleich eingefügt

If TypeName(ActiveSheet) = "Worksheet" Then

OldRange = ActiveCell.Address

Register = ActiveSheet.Name

OldColorIndex = ActiveCell.Interior.ColorIndex

With ActiveSheet

' .Unprotect "Test"

ActiveCell.Interior.ColorIndex = 3

' .Protect "Test"

End With

End If

End Sub



Private Sub Workbook_SheetActivate(ByVal Sh As Object)

' nach Hinweis von Peter Hasserodt Vergleich eingefügt

Aktion = False

If TypeName(ActiveSheet) = "Worksheet" Then

OldRange = ActiveCell.Address

OldColorIndex = ActiveCell.Interior.ColorIndex

With ActiveSheet

' .Unprotect "Test"

ActiveCell.Interior.ColorIndex = 3

' .Protect "Test"

End With

Register = ActiveSheet.Name

End If

End Sub



Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)

Aktion = Not Aktion

If Aktion = True Then

If TypeName(ActiveSheet) = "Worksheet" Then

With Worksheets(Register)

' .Unprotect "Test"

If OldRange <> "" Then .Range(OldRange).Interior.ColorIndex = OldColorIndex

' .Protect "Test"

End With

End If

Else

If TypeName(ActiveSheet) = "Worksheet" Then

With ActiveSheet

' .Unprotect "Test"

' Beim 1. Aufruf ist OldRange noch undefiniert

If OldRange = "" Then

OldRange = Target.Address

OldColorIndex = Target.Interior.ColorIndex

' Setze Hintergrundfarbe der aktiven Selection auf Rot

Target.Interior.ColorIndex = 3

Else

' Setze alten Range auf alte Farbe

If Range(OldRange).Interior.ColorIndex = 3 Then

Range(OldRange).Interior.ColorIndex = OldColorIndex

End If

OldColorIndex = Target.Interior.ColorIndex

' Merke mir aktuellen Adresse für nächsten Aufruf

OldRange = 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



Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)

' nach Hinweis von Peter Hasserodt Vergleich eingefügt

If Aktion = True Then Exit Sub

If TypeName(ActiveSheet) = "Worksheet" Then

With Worksheets(Register)

' .Unprotect "Test"

If OldRange <> "" Then .Range(OldRange).Interior.ColorIndex = OldColorIndex

' .Protect "Test"

End With

End If

End Sub



Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)

' nach Hinweis von Peter Hasserodt Vergleich eingefügt

If Aktion = True Then Exit Sub

If TypeName(ActiveSheet) = "Worksheet" Then

With ActiveSheet

' .Unprotect "Test"

' Beim 1. Aufruf ist OldRange noch undefiniert

If OldRange = "" Then

OldRange = Target.Address

OldColorIndex = Target.Interior.ColorIndex

' Setze Hintergrundfarbe der aktiven Selection auf Rot

Target.Interior.ColorIndex = 3

Else

' Setze alten Range auf alte Farbe

If Range(OldRange).Interior.ColorIndex = 3 Then

Range(OldRange).Interior.ColorIndex = OldColorIndex

End If

OldColorIndex = Target.Interior.ColorIndex

' Merke mir aktuellen Adresse für nächsten Aufruf

OldRange = Target.Address

' Setze Hintergrundfarbe der aktiven Selection auf Rot

Target.Interior.ColorIndex = 3

End If

' .Protect "Test"

End With

End If

End Sub





' **************************************************************

' Modul: Modul1 Typ = Allgemeines Modul

' **************************************************************



Option Explicit

' erstell von Hajo.Ziplies@web.de

Public OldColorIndex As Variant

Public OldRange As String

Public Register As String



Code eingefügt mit: Excel Code Jeanie

 http://hajo-excel.de/fragen_wie_1.htm

Betriebssystem: Windows 10, Office 2016 32 bit. Bitte Version angeben. Bei keiner Angabe wird von meiner  ausgegangen.Mails nur nach Aufforderung.



geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: