AW: Daten von wide in long format umordnen
20.11.2008 11:56:20
wide
Hallo Peter,
Das folgende Makro erledigt die Umstellung. Die Ausgabe erfolgt dabei immer in ein neu angelegtes Blatt.
Gruß
Franz
Sub Umstellen()
Dim wksQ As Worksheet, wksZ As Worksheet
Dim Zeile1 As Long, ZeileL As Long, ZeileZiel As Long, Spalte As Long
Dim rngDatum As Range, rngDaten As Range, strCode As String
Set wksQ = Worksheets("Sheet1") 'Ausgangsdaten-Tabelle
ActiveWorkbook.Worksheets.Add 'neue Tabelle für Zieldaten einfügen
Set wksZ = ActiveSheet 'Zieldaten - Tabelle
Application.ScreenUpdating = False
Zeile1 = 3 '1. Zeile mit Datum in Ausgangsdaten
ZeileZiel = 1 'Titelzeile in Zieltabelle
With wksZ
.Activate
' Spaltentitel im Zielblatt eintragen
.Cells(1, 1) = "Datum"
.Cells(1, 2) = "Code"
.Cells(1, 3) = "ASK PRICE"
.Cells(1, 4) = "BID PRICE"
.Cells(1, 5) = "FREE FLOAT NOSH"
.Cells(1, 6) = "NUMBER OF SHARES"
.Cells(1, 7) = "TURNOVER BY VOLUME"
ZeileZiel = ZeileZiel + 1 '1. Datenzeile in Zieltabelle
'Titelzeilen fixieren
.Cells(ZeileZiel, 1).Select
ActiveWindow.FreezePanes = True
End With
With wksQ
ZeileL = .Cells(.Rows.Count, 1).End(xlUp).Row 'letzte Zeile mit Datum
'Datumsbereich merken
Set rngDatum = .Range(.Cells(Zeile1, 1), .Cells(ZeileL, 1))
'Spalten mit daten abarbeiten
For Spalte = 2 To .Cells(2, .Columns.Count).End(xlToLeft).Column Step 5
'Prüfen, ob Fehler in Code Zeile
If Not (IsError(.Cells(1, Spalte)) Or IsEmpty(.Cells(2, Spalte))) Then
strCode = .Cells(2, Spalte)
'Datenbereich merken
Set rngDaten = .Range(.Cells(Zeile1, Spalte), .Cells(ZeileL, Spalte + 4))
With wksZ
' daten in Zieltabelle kopieren
rngDatum.Copy Destination:=.Cells(ZeileZiel, 1)
rngDaten.Copy Destination:=.Cells(ZeileZiel, 3)
'Code eintragen in Spalte 2
.Range(.Cells(ZeileZiel, 2), _
.Cells(ZeileZiel + rngDatum.Rows.Count - 1, 2)).Value = strCode
End With
ZeileZiel = ZeileZiel + rngDatum.Rows.Count
If ZeileZiel + rngDatum.Rows.Count > .Rows.Count Then
End If
End If
Next
End With
With wksZ
.Range(.Columns(1), .Columns(7)).EntireColumn.AutoFit
End With
Application.ScreenUpdating = True
MsgBox "fertig"
End Sub