Option Explicit
Sub test()
Rem zwingend Name in Spalte "nSpalte", Typ in Spalte "daneben"
Rem Tabelle hat Überschrift (Name, Typ etc.) !
Const nSpalte As Long = 1
Dim qSh As Worksheet
Dim tSh As Worksheet
Dim q As Range, t As Range
Application.ScreenUpdating = False
Set qSh = ActiveSheet
Sheets.Add
Set tSh = ActiveSheet
Set q = Range(qSh.Cells(nSpalte, 1), _
qSh.Cells(qSh.Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row, 1))
For Each t In q
tSh.Range(t.Address).Formula = t.Formula & " " & t.Offset(0, 1).Formula
Next t
Set q = qSh.[A1].End(xlToRight).Offset(0, 2)
With tSh
Application.DisplayAlerts = Not Application.DisplayAlerts
[A:A].Sort Key1:=[A1], Order1:=xlAscending, Header:=xlGuess
[A:A].Subtotal GroupBy:=1, Function:=xlCount, TotalList:=Array(1), _
Replace:=True, PageBreaks:=False, SummaryBelowData:=True
.Outline.ShowLevels RowLevels:=2
For Each t In Range(tSh.Cells(1, 1), _
tSh.Cells(tSh.Cells.Find("*", [A1], , , _
xlByRows, xlPrevious).Row, 1)).SpecialCells(xlCellTypeVisible)
q.Value = Replace(t.Value, " Anzahl", "")
q.Offset(0, 1).Value = t.Offset(0, 1).Value
Set q = q.Offset(1, 0)
Next t
End With
tSh.Delete
qSh.Select
Application.DisplayAlerts = Not Application.DisplayAlerts
Application.ScreenUpdating = True
End Sub