Hallo,

habe eine Muster-Arbeitsmappe erstellt.

Diese enthält zwei Tabellen:

Tabelle 1 enthält alle Strompreise inkl. den drei Text-Zeilen alle 28. Zeile (die Daten werden mit Zufallswerten mit der Sub GerateData erzeugt.)

Tabelle 2 enthält die kopierten Einträge. Diese werden mit der Sub TransposeData generiert.

Hier nochmal der Code von der Sub TransposeData:

Option Explicit

Sub TransposeData()
    Dim wshData As Worksheet
    Dim wshTrans As Worksheet
    Dim lngRowTr As Long
    Dim rngCp As Range, rngCpTimes  As Range
    Dim rng As Range, rnglast As Range
    Set wshData = Worksheets(1)
    Set wshTrans = Worksheets(2)
    lngRowTr = 1
    Application.ScreenUpdating = False
    For Each rng In wshData.UsedRange.Rows
        If IsNumeric(rng.Cells(1, 1).Value) And Len(rng.Cells(1, 1).Value) > 0 Then
            If Not rnglast Is Nothing Then
                If rngCp.Cells.Count = 24 Then
                    RangeTranspose wshTrans, rngCp, rngCpTimes, lngRowTr
                End If
            End If
            If rngCp Is Nothing Then
                Set rngCp = rng.Cells(1, 2)
                If lngRowTr = 1 Then Set rngCpTimes = rng.Cells(1, 1)
            Else
                Set rngCp = Union(rngCp, rng.Cells(1, 2))
                If lngRowTr = 1 Then Set rngCpTimes = Union(rngCpTimes, rng.Cells(1, 1))
            End If
            Set rnglast = rng
        End If
    Next
    RangeTranspose wshTrans, rngCp, rngCpTimes, lngRowTr

    If Not Application.CutCopyMode = False Then
        Application.CutCopyMode = False
    End If
    Application.ScreenUpdating = True
End Sub

Sub RangeTranspose(ByRef wshTrans As Worksheet, ByRef rngCp As Range, ByRef rngCpTimes As Range, ByRef lngRowTr As Long)
    If Not rngCp Is Nothing Then
        ' Transpose
        If lngRowTr = 1 Then
            ' Uhrzeiten transposen
            rngCpTimes.Copy
            wshTrans.Cells(lngRowTr, 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
        End If
        rngCp.Copy
        lngRowTr = lngRowTr + 1
        With wshTrans.Cells(lngRowTr, 1)
            .PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
        End With
        Set rngCp = Nothing
        VBA.DoEvents
    End If
End Sub

LG, Ben