AW: Makro verbessern - Hintergrundfarbe
07.03.2020 14:44:48
Kisska
Hallo Thorsten,
bitte entschuldige die verspätete Antwort.
Ein Upload der Datei ist nicht nötig, da das Beispiel zu einfach ist.
Datei besteht aus 3 leeren Tabellenblättern, in der Zeile 1 stehen jeweils die Überschriften, in der Spalte A jeweils Nummern (1 bis 300). Einige der Überschriften haben eine Hintergrundfarbe. In einem Tabellenblatt gibt es die bedingte Formatierung, dass wenn irgendeine Zelle den Textinhalt "storniert" enthält, diese Zeile dann grau hinterlegt wird.
Ich habe dieses Makro gefunden:
Option Explicit
' erstellt von Hajo.Ziplies@web.de 14.12.02; 29.04.03, 10.10.03, 14.03.04
' http://home.media-n.de/ziplies/
' gesamte Zeile markieren
' alte Farbe wieder zur?ckstellen bei wechsel und schliessen
' farbver?nderungen im markiertem Bereich werden nicht zur?ck gestellt, au?er Rot
' Abschalten durch Doppelklick
' Modifiziert von JFreudens
' Durch Auswertung von Activewindow.ActivePane.VisibleRange
' wird der Aufwand deutlich reduziert. Es wird jetzt ein "Fadenkreuz" eingef?rbt
Dim StWert() As String ' 1=Farbe der Zelle; 2=Zelle; 3= Register
' Dimensionierung erfolgt sp?ter in Abh?ngigkeit der Anzahl der sichtbaren
' Zellen des Fadenkreuzes
Dim InI As Integer
' Merker ob Markierung eingeschaltet, geschieht durch Doppelklick
Dim BoAktion As Boolean
Dim ByFarbe As Byte ' Farbe Markierung
Private Sub Workbook_Open()
ByFarbe = 34 '3 = rot, 4 = hellgr?n, 5 = blau, 15 = grau, 34 = helblau
' nach Hinweis von Peter Haserodt Vergleich eingef?gt ob Tabelle
If TypeName(ActiveSheet) = "Worksheet" Then Auslesen
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
If BoAktion = True Or Target.Count > 1 Then Exit Sub
Zur?ck ' Farben zur?ckstellen
' nach Hinweis von Peter Haserodt Vergleich eingef?gt ob Tabelle
If TypeName(ActiveSheet) = "Worksheet" Then Auslesen ' Farben der aktuellen _
Zeile auslesen
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
If BoAktion = True Then Exit Sub
' nach Hinweis von Peter Haserodt Vergleich eingef?gt ob Tabelle
If TypeName(ActiveSheet) = "Worksheet" Then Zur?ck
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 Zur?ck
End Sub
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
BoAktion = False
Zur?ck
' Nur Bestimmte Zeilen
' nach Hinweis von Peter Haserodt Vergleich eingef?gt
If TypeName(ActiveSheet) = "Worksheet" Then Auslesen
End Sub
Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
If BoAktion = True Then Exit Sub
If TypeName(ActiveSheet) = "Worksheet" Then Zur?ck
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 Zur?ck
Else
If TypeName(ActiveSheet) = "Worksheet" Then Auslesen
End If
Cancel = True
End Sub
Sub Zur?ck()
On Error GoTo Ende_Zur?ck
If StWert(1, 1, 1) "" Then
' Worksheets(StWert(1, 3, 3)).Unprotect
For InI = 1 To UBound(StWert, 1)
If Worksheets(StWert(InI, 3, 3)).Range(StWert(InI, 2, 2)).Interior.ColorIndex = _
ByFarbe Then
Worksheets(StWert(InI, 3, 3)).Range(StWert(InI, 2, 2)).Interior.ColorIndex = _
CInt(StWert(InI, 1, 1))
End If
Next InI
' Worksheets(StWert(1, 3, 3)).Protect
End If
Ende_Zur?ck:
End Sub
Sub Auslesen()
' ActiveSheet.Unprotect
Dim FadenKreuz As Range
Dim Zelle As Range
' Bestimmt den Fadenkreuz-Bereich, der durch die aktive Zelle definiert wird.
' Anschlie?end wird der bereich beschnitten, um nur die zellen des Fadenkreuzes
' zu behalten, die derzeit sichtbar sind
Set FadenKreuz = Intersect(Union(ActiveCell.EntireRow, ActiveCell.EntireColumn), _
ActiveWindow.ActivePane.VisibleRange)
ReDim StWert(1 To FadenKreuz.Cells.Count, 3, 3)
InI = 0
For Each Zelle In FadenKreuz.Cells
InI = InI + 1
StWert(InI, 1, 1) = Zelle.Interior.ColorIndex
StWert(InI, 2, 2) = Zelle.Address
StWert(InI, 3, 3) = ActiveSheet.Name
If Zelle.Interior.ColorIndex = xlNone Then
Zelle.Interior.ColorIndex = ByFarbe
End If
Next
' ActiveSheet.Protect
End Sub
Quelle: https://www.herber.de/forum/archiv/820to824/823442_Fadenkreuz_fuer_aktive_Zelle.html
Der Code ist viel komplexer als bei dir und wahrscheinlich brauche ich viel weniger davon, aber es geht in die Richtung, was ich es haben möchte und zwar:
Egal in welcher Zelle ich mich befinde, soll ein Fadenkreuz zur Hervorhebung temporär gemacht werden, und zwar über das gesamte aktive Tabellenblatt. Hier im Code ist der Fadenkreuz leider abgeschnitten.
Wichtig ist mir, dass vorherigen Hintergrundfarben nicht gelöscht werden bzw. neu gefärbte Zellen ihre Farbe nicht verlieren.
VG, Kisska