Option Explicit
Sub TestIt()
Dim n&
n = transpRecordsets(Source:=Worksheets(1), _
Destination:=Worksheets(2))
If n > 0 Then
Call MsgBox("Es wurden " & IIf(n = 1, n & " Datensatz", n & " Datensätze") & " kopiert.", _
vbInformation)
Else
Call MsgBox("Keine Datensätze vorhanden/gefunden.", _
vbExclamation)
End If
End Sub
Public Function transpRecordsets(Source As Excel.Worksheet, Destination As Excel.Worksheet) As Long
Dim rng As Excel.Range
Dim rngRS As Excel.Range
Dim bRecordset As Boolean
Dim bEntry As Boolean
Dim bCopyHeader As Boolean
Dim rid&, n&
Set rng = Source.Range("B2")
bCopyHeader = True
rid = 2
bRecordset = Len(Trim(rng.Text)) > 0
While bRecordset
Set rngRS = Nothing
bEntry = Len(Trim(rng.Offset(ColumnOffset:=1).Text)) > 0
While bEntry
If Not rngRS Is Nothing Then
Set rngRS = Union(rng.Offset(ColumnOffset:=1).Resize(ColumnSize:=2), _
rngRS)
Else
Set rngRS = rng.Offset(ColumnOffset:=1).Resize(ColumnSize:=2)
End If
Set rng = rng.Offset(RowOffset:=1)
bEntry = Len(Trim(rng.Offset(ColumnOffset:=1).Text)) > 0
Wend
If Not rngRS Is Nothing Then
If bCopyHeader Then
bCopyHeader = False
If rid > 1 Then
rngRS.Columns(1).Copy
Destination.Rows(rid - 1).PasteSpecial xlPasteValues, Transpose:=True
End If
End If
rngRS.Columns(2).Copy
Destination.Rows(rid).PasteSpecial xlPasteValues, Transpose:=True
Application.CutCopyMode = False
rid = rid + 1
n = n + 1
End If
Set rng = rng.Offset(RowOffset:=1)
bRecordset = Len(Trim(rng.Text)) > 0
Wend
transpRecordsets = n
End Function