Hallo Carsten,
das folgende Makro gehört in ein Standardmodul deiner Arbeitsmappe:
Sub sortieren()
Dim lngLetzte As Long
Dim varArtikelnr As Variant
Dim lngZeile As Long
Dim lngStart As Long
Dim bFarbe As Boolean
'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False
With ActiveSheet
'letzte beschriebene Zeile ermitteln
lngLetzte = .UsedRange.SpecialCells(xlCellTypeLastCell).Row
'Daten sortieren
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=.Range("B2:B" & lngLetzte), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortTextAsNumbers
.Sort.SortFields.Add Key:=.Range("C2:C" & lngLetzte), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortTextAsNumbers
With .Sort
.SetRange Range("A1:H" & lngLetzte)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'letzte beschriebene Zeile in Spalte B ermitteln
lngLetzte = .Cells(Rows.Count, 2).End(xlUp).Row
'Variable für Artikelnummer neuen Wert zuweisen
varArtikelnr = .Cells(lngLetzte, 2)
'Variable für Startzeile festlegen
lngStart = lngLetzte
'Artikelnummern ab Zeile 3 durchlaufen und Gruppen mit gleicher Artikelnummer bilden
For lngZeile = lngLetzte To 1 Step -1
'Prüfen, ob neue Artikelnummer vorliegt
If Cells(lngZeile, 2) <> "" And Cells(lngZeile, 2).Value <> varArtikelnr Then
'leere Zeile einfügen
.Rows(lngZeile + 1).Insert
'prüfen ob Bereich eingefärbt werden muss; abwechselnd färben und nicht färben
If bFarbe = False Then
'Zellen A bis H einfärben
With .Range(.Cells(lngStart + 1, 1), Cells(lngZeile + 2, 8)).Interior
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.14996795556505
.PatternTintAndShade = 0
End With
'Marker auf wahr setzen
bFarbe = True
Else
bFarbe = False
End If
'Variable für Artikelnummer neuen Wert zuweisen
varArtikelnr = .Cells(lngZeile, 2)
'neue Startzeile festlegen
lngStart = lngZeile
End If
Next lngZeile
End With
'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True
End Sub
Gruß
M.O.