VBA - 1 Codefehler habe ich noch | HERBERS Excel Forum

Hallo,
Schon vor längerer Zeit habe ich aus dem Internet einen Code erhalten, der in einer gefilterten Tabelle bezugnehmend auf die Spalte A blockweise Hintergrundfarben setzt.
Den Code habe ich in der personl.xls gespeichert, damit er immer zur Verfügung steht. Bei jedem Klick auf die eigens erstellte Schaltfläche in der Symbolleiste wird wieder der nächste TextBlock markiert.
Der Code funktioniert soweit auch ganz gut, allerdings kommt es manchmal vor, dass der Code abbricht und dann wird die Zeile booGoErste = Intersect(rngAktuell, rngVisibleRange) Is Nothing

markiert. Wenn ich den Debugger beende, kann ich normal weiterklicken und der Code markiert wie gewünscht.
Ich komme einfach nicht dahinter, wieso hier ein Fehler kommt.
Wenn ich den Code direkt in eine Mappe kopiere kommt nie ein Fehler. Er sollte aber in der personl.xls laufen.
Zum besseren Verständnis habe ich den Code in eine Beispielmappe kopiert. Vielleicht weiß jemand Rat.
https://www.herber.de/bbs/user/78727.xls
Bin gespannt, Danke und Servus, Walter

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Hallo
On Error Resume Next unter die letzte Dim-Anweisung

Option Explicit
Sub Walter()
Dim lngLetzte As Long, nCount As Long
Dim rngVisibleRange As Range
Static rngAktuell As Range
Dim booGoErste As Boolean
Dim LCol As Integer
Dim LoJ As Long
Dim i
Dim j
Dim k
Dim l
On Error Resume Next
LCol = Cells(2, Columns.Count).End(xlToLeft).Column
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
i = Application.Match("BEZEICHNUNG", Rows(2), 0)
j = Application.Match("JÄNNER", Rows(2), 0)
k = Application.Match("DEZEMBER", Rows(2), 0)
l = Application.Match("GESAMT", Rows(2), 0)
Range(Cells(3, 1), Cells(65536, i - 1)).Interior.ColorIndex = xlNone
Range(Cells(3, i + 1), Cells(65536, j - 1)).Interior.ColorIndex = xlNone
Range(Cells(3, k + 1), Cells(65536, LCol)).Interior.ColorIndex = xlNone
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, i - 1)).Interior.Color = 16764108
Range(Cells(rngAktuell.Row, i + 1), Cells(LoJ - 1, j - 1)).Interior.Color = 16764108
Range(Cells(rngAktuell.Row, k + 1), Cells(LoJ - 1, LCol)).Interior.Color = 16764108
End Sub

Gruß Matthias

Beliebteste Forumthreads (12 Monate)

VBA - 1 Codefehler habe ich noch

10 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread