|
Hallo,
vorausgesetzt, dass deine Liste in Zelle A1 mit der Überschrift "Datum" beginnt.
Sub Schaltfläche1_Klicken()
Dim loZeile As Long, loSpalte As Long, i As Long
Application.ScreenUpdating = False
With Worksheets("Tabelle1")
With Worksheets("Tabelle2")
.Range(.Cells(1, "A"), .Cells(1, "C")) = Array("Aktie", "Datum", "Preis")
End With
For i = 2 To .Cells(1, .Columns.Count).End(xlToLeft).Column
loZeile = .Cells(.Rows.Count, i).End(xlUp).Row
loVersatz = .Cells(.Rows.Count, i).End(xlUp).Row - 1
.Range(.Cells(2, "A"), .Cells(loZeile, "A")).Copy
With Worksheets("Tabelle2")
.Cells(.Rows.Count, "B").End(xlUp).Offset(1).PasteSpecial _
Paste:=xlPasteValuesAndNumberFormats
End With
.Range(.Cells(2, i), .Cells(loZeile, i)).Copy
With Worksheets("Tabelle2")
.Cells(.Rows.Count, "C").End(xlUp).Offset(1).PasteSpecial _
Paste:=xlPasteValuesAndNumberFormats
.Cells(.Cells(.Rows.Count, "A").End(xlUp).Offset(1).Row, "A").Resize(loVersatz) _
= Worksheets("Tabelle1").Cells(1, i)
End With
Next i
End With
With Worksheets("Tabelle2")
loZeile = .Cells(.Rows.Count, "C").End(xlUp).Row
If WorksheetFunction.CountBlank(.Range("C1:C" & loZeile)) > 0 Then
.Range("C1:C" & loZeile).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End If
End With
Application.CutCopyMode = False
End Sub
Die neue Liste wird in Tabelle2 erstellt.
Gruß Werner
|