AW: Pivotisieren ohne Berechnung?
30.09.2010 06:55:35
fcs
Hallo Wilfied,
eine solche Umgruppierung der Daten ist per Formel nur schwierig zu relisieren.
Nachfolgend eine Makro-Lösung.
Gruß
Franz
Sub DatenUmgruppieren2()
Dim wksOrig As Worksheet, wksNeu As Worksheet
Dim Zeile As Long, ZeileLetzte As Long, Spalte As Long
Dim oCollection As New Collection, iIndex As Long
Dim sVergleich As String, ZeileZiel As Long
On Error GoTo Fehler
Set wksOrig = ActiveSheet
'Kopie des Originalblatts erstellen
wksOrig.Copy After:=wksOrig
Set wksNeu = ActiveSheet
Application.ScreenUpdating = False
'In Kopie die Daten umgruppieren
With wksNeu
'letzte Zeile in Tabelle
ZeileLetzte = .Cells(.Rows.Count, 1).End(xlUp).Row
'Verschiedene Stage-Nummern in Spalte 4 ermitteln und in Zeile 1 eintragen
Spalte = 6
For Zeile = 2 To ZeileLetzte
oCollection.Add Item:=.Cells(Zeile, 4), Key:=CStr(.Cells(Zeile, 4))
'Stage-Nummer in Zeile 1 eintragen
.Cells(1, Spalte).Value = .Cells(Zeile, 4).Value
'etwas größere Nummer zum späteren Sortieren in rechte Nachbarspalte eintragen
.Cells(1, Spalte + 1).Value = .Cells(Zeile, 4).Value + 0.1
'Zellenformate der Spalten setzen
With .Columns(Spalte)
.NumberFormat = .Cells(2, 4).NumberFormat
End With
With .Columns(Spalte + 1)
.NumberFormat = .Cells(2, 5).NumberFormat
End With
Spalte = Spalte + 2
Resume01:
Next
'Spalten mit Stage-Nummern sortieren
With .Range(.Cells(1, 6), .Cells(1, .Columns.Count).End(xlToLeft))
.Sort key1:=.Range("A1"), order1:=xlAscending, Header:=xlNo, Orientation:=2 'xlSortRows
End With
'Daten nach Spalten A bis C mit Schlüsseldaten sortieren (Vorsichtsmassnahme)
With .Range(.Cells(1, 1), .Cells(ZeileLetzte, 5))
.Sort key1:=.Range("A1"), order1:=xlAscending, _
key2:=.Range("B1"), order2:=xlAscending, _
key3:=.Range("C1"), order3:=xlAscending, Header:=xlYes, Orientation:=1 'xlSortColumns
End With
'Daten umgruppieren ab Zeile 2
sVergleich = ""
For Zeile = 2 To ZeileLetzte
If sVergleich .Cells(Zeile, 1).Text & .Cells(Zeile, 2).Text _
& .Cells(Zeile, 3).Text Then
'Neue Zielzeile
ZeileZiel = Zeile
'Neuer Vergleichsschlüssel zusammengesetzt aus Spalten 1 bis 3
sVergleich = .Cells(ZeileZiel, 1).Text & .Cells(ZeileZiel, 2).Text _
& .Cells(ZeileZiel, 3).Text
End If
'Stage-Nummer vergleichen und Zielspalte ermitteln
For Spalte = 6 To .Cells(1, .Columns.Count).End(xlToLeft).Column Step 2
If .Cells(Zeile, 4).Value = .Cells(1, Spalte) Then
'"P_PST Stage" übertragen
.Cells(ZeileZiel, Spalte) = .Cells(Zeile, 4)
'"P_PST Pack Responsibility" übertragen
.Cells(ZeileZiel, Spalte + 1) = .Cells(Zeile, 5)
Exit For
End If
Next
If Zeile ZeileZiel Then .Rows(Zeile).ClearContents
Next
'Spalten-Titel eintragen
Spalte = 6
iIndex = 1
For Spalte = 6 To .Cells(1, .Columns.Count).End(xlToLeft).Column Step 2
'Spaltentitel in Zeile 1 ergänzen
.Cells(1, Spalte) = "Stage " & iIndex
.Cells(1, Spalte + 1) = "PR " & iIndex
iIndex = iIndex + 1
Next
'Spaltentitel formatieren
.Cells(1, 4).Copy
With .Range(.Cells(1, 6), .Cells(1, .Columns.Count).End(xlToLeft))
.PasteSpecial Paste:=xlPasteFormats
.EntireColumn.AutoFit
End With
'Rahmen für neue Spalten formatieren
With .Range(.Cells(1, 6), .Cells(ZeileLetzte, _
.Cells(1, .Columns.Count).End(xlToLeft).Column))
.Borders.LineStyle = xlContinuous
End With
'Spalten "P_PST Stage" und "P_PST Pack Responsibility" löschen
.Range(.Columns(4), .Columns(5)).Delete
'Leere Zeilen löschen
With .Range(.Cells(1, 1), .Cells(ZeileLetzte, 1))
.SpecialCells(xlCellTypeBlanks).EntireRow.Delete Shift:=xlShiftUp
End With
End With
Fehler:
With Err
Select Case .Number
Case 0 'Alles OK
Case 457 'Doppelten Eintrag in Collection überspringen
Resume Resume01
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbNewLine & .Description
End Select
End With
'Variablen aufräumen
Set oCollection = Nothing
Set wksNeu = Nothing: Set wksOrig = Nothing
Application.ScreenUpdating = True
Range("A1").Select
End Sub