Harte Nuss: ZeilenMarkierung

Sub zurueck()
Dim StKlarname As String                        ' Klarname der Tabelle
On Error Resume Next
If IsError(LBound(StWert())) Then
ReDim Preserve StWert(0 To 1, 0 To 0)       ' Array Definieren
End If
If StName = "" Then Exit 

Sub                    ' es sind keine Werte vorhanden
Dim WsTabelle As Worksheet                      ' Klarname der Tabelle feststellen
For Each WsTabelle In ThisWorkbook.Worksheets   ' Schleife über alle Tabellen
If WsTabelle.CodeName = StName Then         ' Namen mit abgespeicherten vergleichen
StKlarname = WsTabelle.Name             ' Namen auf Register auslesen
Exit For                                ' Schleife verlassen
End If
Next WsTabelle
If StKlarname  "" Then                        ' Tabellename vorhanden
'Farbe zurueckstellen
If Not RaZeile Is Nothing Then
With ThisWorkbook.Worksheets(StKlarname)
'.Unprotect
For InI = 0 To UBound(StWert, 2)
' es gibt auch leere Variablen da Grundlage Fadenkreuz
If StWert(InI, 0)  "" Then
If StWert(1, InI)  "" Then
With .Range(StWert(1, InI)).Interior
If .Color = LoFarbe Then
If StWert(0, InI) = 16777215 Then
Dim LoPattern As Long
Dim LoMuster As Long
If .Pattern = -4142 Or .Pattern = 1 Then
.ColorIndex = xlNone
Else
LoPattern = .PatternColor
LoMuster = .Pattern
.ColorIndex = xlNone
.PatternColor = LoPattern
.Pattern = LoMuster
End If
Else
.Color = StWert(0, InI)
End If
End If
End With
End If
End If
Next InI
'.Protect
End With
End If
End If
End Sub


Sub Auslesen()
Dim RaZelle As Range
Dim StSichtbar_range As String                  ' Sichtbarer Bereich Fixierung unten rechts
Dim LoLetzte As Long                            ' Letzte Zeile Bildschirm
Dim StLinks As String                           ' linke Begrenzung Bildschirm bei Fixierung
Dim StRechts As String                          ' rechte Begrenzung Bildschirm
Dim StZelle As String                           ' Variable das in erster Zeile eine Zelle  _
nicht 2 mal ausgelesen wird
Erase StWert()                                  ' Array löschen
StName = ActiveSheet.CodeName                   ' CodeName der Tabelle
' Bestimmt den Fadenkreuz-Bereich, der durch die aktive Zelle definiert wird.
' Anschließend wird der Bereich beschnitten, um nur die zellen des Zeile
' zu behalten, die derzeit sichtbar sind
Set RaZeile = Intersect(Union(ActiveCell.EntireRow, ActiveCell.EntireColumn), _
ActiveWindow.ActivePane.VisibleRange)
' Tabelle fixiert Zellen im restlichen Bereich feststellen
If ActiveWindow.FreezePanes Then        ' Tabelle ist fixiert
' Der Code zur Ermttlung der Zeile oder Spalten
' wurde von André (Schauan) erstellt
StSichtbar_range = ActiveWindow.ActivePane.VisibleRange.Address(True, False)
' Ansatz von Uwe Küstner ohne Vergleich
' Spalte
' Überprüfung ob Spalte fixiert
If ActiveWindow.SplitColumn  0 Then
Set RaZeile = Range(Cells(ActiveCell.Row, 1), _
Cells(ActiveCell.Row, ActiveWindow.SplitColumn))
ElseIf ActiveWindow.SplitRow  0 Then  ' Überprüfung ob Zeile fixiert
Set RaZeile = Range(Left(StSichtbar_range, InStr(StSichtbar_range, "$")) & 1 & Mid( _
StSichtbar_range, InStr(StSichtbar_range, ":")))
End If
End If
InI = 0
'ActiveSheet.Unprotect
For Each RaZelle In RaZeile
With RaZelle
' nur Zellen der aktiven Zeile
If InStr(StZelle, RaZelle.Address) = 0 Then
If RaZelle.Row = ActiveCell.Row Then
InI = InI + 1
ReDim Preserve StWert(0 To 1, 0 To InI - 1)
StWert(0, InI - 1) = RaZelle.Interior.Color
StWert(1, InI - 1) = RaZelle.Address
StZelle = StZelle & RaZelle.Address
.Interior.Color = LoFarbe
End If
End If
End With
Next RaZelle
'ActiveSheet.Protect
End Sub