VBA Blockweise scrollen
31.03.2013 19:53:24
WalterK
Der folgende Code scrollt Blockweise, d.h. ausgehend von einer Datenreihe in einer Spalte wird immer bei jedem neuerlichen Klick der nächste Block unter die fixierte Zeile 2 geholt. Die Blocklänge ist unterschiedlich.
Ich wollte den Code auf eine andere Tabelle anpassen, bring es aber nicht zum Laufen. Der Zeilen 1+2 sind fixiert, die Daten stehen von A3:Q?. Die Spalte mit den Datenblöcken ist jetzt aber die Spalte EL.
Sub ReihefürReiheScrollen()
Dim rngVisibleRange As Range
Dim lngLetzte As Long, nCount As Long
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
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
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
Im obigen Code habe ich noch nichts geändert.
Besten Dank für die Hilfe und Servus, Walter