VBA-Code funktioniert nicht jedesmal
WalterK
ich stelle mein Problem nochmals ein, vielleicht gibt es doch noch ein Lösung.
Den untenstehenden Code habe ich im Forum erhalten. Er ermöglicht mir das blockweise scrollen in Tabellen, die ich mehrmals täglich erhalte. Damit mir der Code immer zur Vergügung steht, habe ich ihn in der Personl.xls hinterlegt, er wird über eine in einer Symbolleiste angelegte Schaltfläche aktiviert.
Das Problem ist, dass der Code über die Personl.xls nur jedes 2. Mal funktioniert. Jedes andere Mal kommt der Debugger, es ist dann die Zeile booGoErste = Intersect(rngAktuell, rngVisibleRange) Is Nothing gelb markiert und es wird der Fehler "Laufzeitfehler 1004: Die Methode Intersect für das Objekt _Global ist fehlgeschlagen angezeigt.
Wenn ich den Code direkt in die Arbeitsmappe kopiere dann funktioniert er jedesmal. Er sollte aber über die Personl.xls fehlerfrei laufen.
Wer kann mir bei meinem Problem weiterhelfen?
Hier noch der Code und eine Arbeitsmappe:
Option Explicit
Sub Tabellescrollen()
Dim rngVisibleRange As Range
Dim lngLetzte As Long, nCount As Long
Dim booGoErste As Boolean
Dim LCol As Integer
LCol = Cells(2, Columns.Count).End(xlToLeft).Column
Static rngAktuell As Range
Set rngVisibleRange = Range("A3", Cells(Rows.Count, 1)).SpecialCells(xlCellTypeVisible)
booGoErste = rngAktuell Is Nothing
If Not booGoErste Then
booGoErste = Intersect(rngAktuell, rngVisibleRange) Is Nothing
End If
If booGoErste Then
Set rngAktuell = rngVisibleRange
Set rngAktuell = rngAktuell.Cells(1, 1)
Application.Goto rngAktuell, True
Exit Sub
End If
lngLetzte = Cells(Rows.Count, 1).End(xlUp).Row
nCount = rngAktuell.Row + 1
Do While rngAktuell.Row lngLetzte Then
Set rngAktuell = Range("A3", Cells(Rows.Count, 1)).SpecialCells(xlCellTypeVisible)
Set rngAktuell = rngAktuell.Cells(1, 1)
' rngAktuell ist die erste Zelle des blocks
Application.Goto rngAktuell, True
End If
Range(Cells(3, 1), Cells(65536, 3)).Interior.ColorIndex = xlNone
Range(Cells(3, 5), Cells(65536, LCol)).Interior.ColorIndex = xlNone
Dim LoJ As Long
For LoJ = rngAktuell.Row To lngLetzte
If Cells(LoJ, 1) rngAktuell.Value Then Exit For
Next LoJ
Range(Cells(rngAktuell.Row, 1), Cells(LoJ - 1, 3)).Interior.Color = 16764108
Range(Cells(rngAktuell.Row, 5), Cells(LoJ - 1, LCol)).Interior.Color = 16764108
End Sub
Danke und Servus, Walter
Anzeige