AW: Fadenkreuz
24.07.2011 14:30:50
Hajo_Zi
Hallo wafi,
das mit dem Schutz war die fehlende Information. Ich habe die Datei auf der HP geändert.
Sub Auslesen()
Dim RaZelle As Range ' Variable für Zelle
' Sichtbarer Bereich Fixierung unten rechts
Dim StSichtbar_range As String
Dim LoLetzte As Long ' Letzte Zeile Bildschirm
' linke Begrenzung Bildschirm bei Fixierung
Dim StLinks As String
Dim StRechts As String ' rechte Begrenzung Bildschirm
' jede Tabelle mit einer anderen Farbe von Farbindex 3 bis 55
Dim LoPattern As Long ' Farbe des Musters
Dim LoMuster As Long ' Muster
DoFarbe = ActiveSheet.Index Mod 53 + 3
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 Fadenkreuzes zu behalten,
' die derzeit sichtbar sind
Set RaFadenKreuz = 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
If RaFadenKreuz Is Nothing Then
Set RaFadenKreuz = Range(Cells(ActiveCell.Row, 1), _
Cells(ActiveCell.Row, ActiveWindow.SplitColumn))
Else
Set RaFadenKreuz = Union(RaFadenKreuz, _
Range(Cells(ActiveCell.Row, 1), _
Cells(ActiveCell.Row, ActiveWindow.SplitColumn)))
End If
End If
' Zeile
' Überprüfung ob Zeile fixiert
If ActiveWindow.SplitRow 0 Then
If RaFadenKreuz Is Nothing Then
Set RaFadenKreuz = Range(Cells(1, ActiveCell.Column), _
Cells(ActiveWindow.SplitRow, ActiveCell.Column))
Else
Set RaFadenKreuz = Union(RaFadenKreuz, _
Range(Cells(1, ActiveCell.Column), _
Cells(ActiveWindow.SplitRow, ActiveCell.Column)))
End If
End If
If ActiveCell.Column ActiveWindow.SplitRow Then
' Zelle in den Fenstern unten Links der Fixierung
' Der Code zur Ermttlung der Zeile oder Spalten
' wurde von André (Schauan) erstellt
' Ermittlung der untersten Zeile des Bildsachirms
' Unterste Zeile des sichbaren Bereiches unten
LoLetzte = ActiveWindow.ActivePane.VisibleRange.Row + _
ActiveWindow.ActivePane.VisibleRange.Rows.Count - 1
Set RaFadenKreuz = Union(RaFadenKreuz, _
Range(Cells(ActiveWindow.ActivePane.VisibleRange.Row, _
ActiveCell.Column), Cells(LoLetzte, ActiveCell.Column)))
ElseIf ActiveCell.Column > ActiveWindow.SplitColumn And _
ActiveCell.Row
Gruß Hajo