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
|