Option Explicit Sub StichwortVerzeichnis() Dim i As Long 'Zeilenzähler Dim x As Integer, y% 'Zähler um Arr() zu erweitern Dim flag As Boolean Dim arr As Variant 'ein DummyArray Dim arrIndex As Integer 'der Zähler fürs DummyArray Dim arr2() As Variant With Sheets("Tabelle1") 'Spalten A:B in ein Array shreiben 'transposed also statt Arr(1 to 2, 1 to k) == Arr (1 to k, 1 to 2) arr = Application.Transpose(Range(.Cells(1, 1), .Cells(.Cells(Rows.Count, 1).End(xlUp).Row, 2))) x = 1 'Schleife über alle belegten Zeilen in A For i = 1 To .Cells(Rows.Count, 1).End(xlUp).Row 'Arr(1 to 2, 1 to x) sukzessive abgleichen mit cells(i,1) also nach dem Stichwort For arrIndex = LBound(arr, 2) To UBound(arr, 2) If .Cells(i, 1) = arr(1, arrIndex) Then 'Wenn Zelleintrag = vorh. Seitenzahl+1 If Cells(i, 2) = Right(arr(2, arrIndex), 3) + 1 Then 'wenn vorh. Arrayeintrag schon ein Paket ist ( erkennt man am "-") für Seitenzahlen 1-9 If Left(Right(arr(2, arrIndex), 3), 1) = "-" Then 'dann ersetze bisherige letzte Seite des Päkchens mit der neuen arr(2, arrIndex) = Left(arr(2, arrIndex), Len(arr(2, arrIndex)) - 2) & " " & .Cells(i, 2) Else 'wenn vorh. Arrayeintrag schon ein Paket ist ( erkennt man am "-") für Seitenzahlen 10-99 If Left(Right(arr(2, arrIndex), 4), 1) = "-" Then 'dann ersetze bisherige letzte Seite des Päkchens mit der neuen arr(2, arrIndex) = Left(arr(2, arrIndex), Len(arr(2, arrIndex)) - 3) & " " & .Cells(i, 2) Else 'wenn vorh. Arrayeintrag schon ein Paket ist ( erkennt man am "-") für Seitenzahlen 10-99 If Left(Right(arr(2, arrIndex), 5), 1) = "-" Then 'dann ersetze bisherige letzte Seite des Päkchens mit der neuen arr(2, arrIndex) = Left(arr(2, arrIndex), Len(arr(2, arrIndex)) - 4) & " " & .Cells(i, 2) Else 'sonst mach ein Päkchen arr(2, arrIndex) = Left(arr(2, arrIndex), Len(arr(2, arrIndex))) & " - " & .Cells(i, 2) End If End If End If 'sonst fang neues Päkchen an Else: arr(2, arrIndex) = arr(2, arrIndex) & ", " & .Cells(i, 2) End If Exit For End If Next Next End With 'Weil das array so zerpflückt aussieht und wir in der neuen Tabelle was bereinigtes haben wollen, erzeugen wir ein bereinigtes array y = 1 ReDim Preserve arr2(1 To UBound(arr, 2)) For x = LBound(arr, 2) To UBound(arr, 2) If Not IsNumeric(arr(2, x)) Then 'wenn die erste Seitenzahl doppelt ist -> das Stichwort ist nur einmal in der Tabelle enthalten If InStr(1, arr(2, x), Left(arr(2, x), 2)) = 1 Then 'dann übernimm das Stichwort + das um den Doppeleintrag bereinigten Seitenindex ins neue array arr2(y) = arr(1, x) & " : " & Right(arr(2, x), Len(arr(2, x)) - 3) End If y = y + 1 End If Next x 'sicherheitshalber;-) ein neues Sheet anlegen Sheets.Add 'das transpose Array wieder umtransposen und an den Range im neuen Sheet übergeben Range(Cells(1, 1), Cells(UBound(arr, 2), 1)) = Application.Transpose(arr2) Columns("A:A").AutoFit End Sub