|
nur so zum Spaß einmal von hinten, durch die Brust ins Auge
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
|