Office: (Office 2010) VBA Zeilenblöcke abwechselnd färben / nicht färben

Hallo liebe Office-Hilfe.com-Gemeinde,
Da ich hier bereits erstklassige Erfahrung bei der Hilfe zur Lösung eines Problems gemacht habe, wende ich mich nochmal an euch.

Ich habe eine Excel-Tabelle (siehe Datei 'Excel-Forum 3') mit unterschiedlich langen Zeilenblöcken.
Die Zeilenblöcke beinhalten Lieferabrufe von Bauteilen und sind chronologisch sortiert (neueste Abruf-Nr. oben).

Nun würde ich gerne diese Blöcke farblich voneinander abheben, um die Übersicht zu verbessern.
Das habe ich jetzt auch schon versucht, indem ich alle geraden Abruf-Nr. (Sp G) blau gefärbt habe - die ungeraden bleiben ohne Füllung.

Code:

Sub Faerben Makro ()
Dim lZeile As Long

   With ThisWorkbook.Worksheets("Tabelle1")
      For lZeile = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
         If Cells(lZeile, 11) Mod 2 <> 0 Then
            .Range("A" & lZeile & ":AV" & lZeile).Interior.Color = RGB(184, 204, 228) 'blauton
         End If
      Next lZeile
   End With
   
End Sub

An der Grenze zwischen zwei Bauteilen (z.B. Zeile 113 & 114) gibt es dann aber manchmal Probleme, da das Ventil bspw. mit Abruf Nr. 1 endet (ungerade; =ohne Füllung) und die Buche mit Abruf Nr. 7 beginnt (ungerade; =ohne Füllung). Hier geht der farbliche Abhebung verloren.
Gibt es eine Möglichkeit die Blöcke, unabhängig von gerade oder ungerade, einfach abwechselnd zu färben?
Als Kriterium könnte man hier evtl. die 'Verkettung 2' (Sp B) verwenden, da dies eine eindeutige Bezeichnung für einen Block ist.

Ich hoffe sehr auf eure Hilfe und freue mich schon auf mögliche Antworten und/oder Anregungen!

Beste Grüße,
Jan

 

Hi Jan,

als Basis für die Farbunterschiedung lässt sich doch m.E. ganz einfach der Inhalt von Spalte B heranziehen - gleiche Nummern -> gleiche Farbe und das immer abwechselnd blau oder farblos:

Code:

Sub Faerben()
    Dim lngZeile As Long
    Dim lngAnzahl As Long
    For lngZeile = 2 To IIf(IsEmpty(Cells(Rows.Count, 1)), Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count)
        lngAnzahl = Application.CountIf(Columns(2), Cells(lngZeile, 2))
        If Cells(lngZeile - 1, 1).Interior.ColorIndex = xlNone Then
            Range(Cells(lngZeile, 1), Cells(lngZeile + lngAnzahl - 1, 48)).Interior.Color = RGB(184, 204, 228)
        End If
        lngZeile = lngZeile + lngAnzahl - 1
    Next lngZeile
End Sub

Bis später,
Karin

 

Hi Karin,

Vielen Dank für deine super schnelle Hilfe - mal wieder! :D
Alles funktioniert bestens!

Liebe Grüße,
Jan