Option Explicit
Private Type tRecord
Name As String
Value As Variant
Format As String
End Type
Private Type tRecordset
Record() As tRecord
Count As Long
End Type
Sub TestIt()
transpRecordsets Worksheets("Page 1"), Worksheets("Sheet1")
End Sub
Public Sub transpRecordsets(Source As Excel.Worksheet, Destination As Excel.Worksheet)
Destination.UsedRange.Clear
Application.ScreenUpdating = False
Dim rng As Excel.Range
Dim rs As tRecordset
Dim result&, rid&, n&, i&
Dim bCopyHeader As Boolean
Dim bExit As Boolean
bCopyHeader = True
rid = 2
Set rng = Source.Range("B2")
While Not bExit
result = GetNextRecordset(rng, rs)
If result = 1 Then
For i = 1 To rs.Count
If rid > 1 And bCopyHeader Then
With Destination.Cells(rid - 1, i)
.Font.Bold = True
.Value = rs.Record(i).Name
.WrapText = False
End With
End If
With Destination.Cells(rid, i)
.NumberFormat = rs.Record(i).Format
.Value = rs.Record(i).Value
.WrapText = False
End With
Next
bCopyHeader = False
rid = rid + 1
n = n + 1
Else
bExit = True
End If
Wend
Application.ScreenUpdating = True
If result <> -1 Then
If n <> 1 Then
Call MsgBox("Es wurden " & n & " Datensätze kopiert.", vbInformation)
Else
Call MsgBox("Es wurde 1 Datensatz kopiert.", vbInformation)
End If
Else
Call MsgBox("Datensätze konnten nicht alle verarbeitet werden " & vbNewLine & "(" & n & " DS kopiert).", _
vbExclamation)
End If
End Sub
Private Function GetNextRecordset(Ref As Excel.Range, Recordset As tRecordset) As Long
If Len(Trim(Ref.Cells(1).Text)) = 0 Then
Set Ref = Ref.Offset(RowOffset:=1)
End If
If Len(Trim(Ref.Cells(1).Text)) > 0 Then
Dim c As Excel.Range
Dim rs As tRecordset
Dim bRecord As Boolean
Dim bAdd2Prev As Boolean
bRecord = Len(Trim(Ref.Offset(ColumnOffset:=1).Cells(1).Text)) > 0
While bRecord
If rs.Count > 0 And Len(Trim(Ref.Cells(1).Text)) > 0 Then
rs.Count = 0
Erase rs.Record
GetNextRecordset = -1
Exit Function
ElseIf Len(Trim(Ref.Offset(ColumnOffset:=1).Cells(1).Text)) > 0 _
And Not Ref.Offset(ColumnOffset:=1).MergeCells Then
bAdd2Prev = False
ElseIf Len(Trim(Ref.Offset(ColumnOffset:=1).Cells(1).Text)) > 0 _
And Ref.Offset(ColumnOffset:=1).MergeCells Then
bAdd2Prev = True
Else
bRecord = False
End If
If bRecord Then
rs.Count = rs.Count + 1
ReDim Preserve rs.Record(1 To rs.Count)
With rs.Record(rs.Count)
.Name = Ref.Offset(ColumnOffset:=1).Cells(1).Text
If Not bAdd2Prev Then
.Value = Ref.Offset(ColumnOffset:=2).Cells(1).Value
Else
For Each c In Ref.Offset(ColumnOffset:=2).Resize(Ref.Offset(ColumnOffset:=1).MergeArea.Rows.Count, 1).Cells
.Value = .Value & IIf(Not IsEmpty(.Value), vbNewLine, "") & c.Value
Next
End If
.Format = Ref.Offset(ColumnOffset:=2).Cells(1).NumberFormat
End With
Set Ref = Ref.Offset(RowOffset:=1)
End If
Wend
Recordset = rs
rs.Count = 0
Erase rs.Record
GetNextRecordset = 1
Else
End If
End Function