VBA Lösung zusammengehörige Zeilen farbig markieren

Question

Hallo zusammen,
möchte gerne in einer längeren Liste zur Übersichtlichkeit Zeilen, die zusammengehören mit der einer bestimmten Farbe markieren, so dass sie sich von anderen Zeilen absetzen. Die Zusammengehörigkeit wird durch ein gleiches Merkmal in der ersten Spalte bestimmt. Hier mal ein Beispiel:

Warengruppe Bezeichnung Eigenschaft
1111 Pflaumen blau
1111 Pflaumen gelb
3333 Limonen grün
3333 Zitronen gelb
4444 Tomaten klein
4444 Tomaten groß
5555 Haselnüsse klein
5555 Walnüsse groß

Das Merkmal der Zusammengehörigkeit wäre hier die Warengruppe, das heißt, dass die ersten beiden Zeilen z.B. gelb markiert werden sollen, die 3. und 4. Zeile blau, die 4. und 5. Zeile wieder gelb usw. Wichtig ist, dass die kompletten Zeilen markiert sind, also auch die Bezeichnungen und die Eigenschaften.

Danke für eine Lösung für Excel 2013
Peter

Answer 1

hi Peter ^^

wie gewünscht

gruss nighty

Sub Farbe()
Dim Findex As Integer
Dim Cwert As Long, Czeile As Long, Azeile As Long
Cwert = Cells(2, 1)
Czeile = 2
For Azeile = 2 To ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1
If Cells(Azeile, 1) <> Cwert Then
If Findex = 4 Then
Findex = 5
Else
Findex = 4
End If
Range(Cells(Czeile, 1), Cells(Azeile - 1, ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Column)).Font.ColorIndex = Findex
Cwert = Cells(Azeile, 1)
Czeile = Azeile
End If
Next Azeile
End Sub

Answer 2

hi all ^^

zur Vereinfachung der farbauswahl entsprechende dialogfenster

gruss nighty

Sub Farbe()
Dim Findex As Integer
Dim Cwert As Long, Czeile As Long, Azeile As Long
Application.Dialogs(xlDialogEditColor).Show 4, 255, 0, 0
Application.Dialogs(xlDialogEditColor).Show 5, 255, 0, 0
Cwert = Cells(2, 1)
Czeile = 2
For Azeile = 2 To ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1
If Cells(Azeile, 1) <> Cwert Then
If Findex = 4 Then
Findex = 5
Else
Findex = 4
End If
Range(Cells(Czeile, 1), Cells(Azeile - 1, ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Column)).Font.ColorIndex = Findex
Cwert = Cells(Azeile, 1)
Czeile = Azeile
End If
Next Azeile
End Sub