AW: Senkrecht zu Waagrecht - Makrolösung
31.10.2006 08:55:51
fcs
Hallo Michel,
hier auch noch eine Makrolösung
Gruss
Franz
Sub Umgruppieren()
Dim wksQ As Worksheet, wksZ As Worksheet
Dim ZeileQ As Long, ZeileZ As Long, SpalteMax As Integer, SpalteZ As Integer
Set wksQ = Worksheets("Tabelle1")
Set wksZ = Worksheets("Tabelle2")
'Inhalte in Zieltabelle löschen
wksZ.UsedRange.ClearContents
ZeileQ = 1 'Zeile mit Spaltentiteln in Quell-Tabelle
ZeileZ = 1 'Zeile für Überschrift in Ziel-Tabelle
With wksQ
'Überschriften übertragen
wksZ.Cells(ZeileZ, 1).Value = .Cells(ZeileQ, 1).Value
wksZ.Cells(ZeileZ, 2).Value = .Cells(ZeileQ, 2).Value
wksZ.Cells(ZeileZ, 3).Value = .Cells(ZeileQ, 3).Value
'Werte übertragen
SpalteMax = 0
For ZeileQ = ZeileQ + 1 To .Cells(.Rows.Count, "A").End(xlUp).Row
If .Cells(ZeileQ, 1) = .Cells(ZeileQ - 1, 1) Then
SpalteZ = SpalteZ + 1
If SpalteZ > SpalteMax Then SpalteMax = SpalteZ
Else
ZeileZ = ZeileZ + 1
wksZ.Cells(ZeileZ, 1).Value = .Cells(ZeileQ, 1).Value
wksZ.Cells(ZeileZ, 2).Value = .Cells(ZeileQ, 2).Value
SpalteZ = 3
End If
wksZ.Cells(ZeileZ, SpalteZ).Value = .Cells(ZeileQ, 3).Value
Next ZeileQ
End With
'Überschrift in Zieltabelle vervollständigen
With wksZ
.Range(.Cells(1, 3), .Cells(1, SpalteMax)).Value = .Cells(1, 3)
End With
End Sub