Damit dürfte es nun laufen:

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
        
        'einmalig Kopfzeile ausfüllen
        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
        
        'Daten in die Zeile schreiben
        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
  
  'eine Leerzeile überspringen ist erlaubt
  If Len(Trim(Ref.Cells(1).Text)) = 0 Then
    Set Ref = Ref.Offset(RowOffset:=1)
  End If
  
  'Anfang Datensatz (DS)?
  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
      'PROBLEM:
      'Angeblich neuer DS erkannt, ohne das der
      'aktuelle DS mit Leerzeile abgeschlossen wurde
        
        rs.Count = 0
        Erase rs.Record
        
        GetNextRecordset = -1
        Exit Function
        
      'Name mit nur einem Wert?
      ElseIf Len(Trim(Ref.Offset(ColumnOffset:=1).Cells(1).Text)) > 0 _
              And Not Ref.Offset(ColumnOffset:=1).MergeCells Then
        bAdd2Prev = False
        
      'Name mit mehreren Werten?
      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
        
        'nächster Eintrag
        Set Ref = Ref.Offset(RowOffset:=1)
      End If
      
    Wend
    
    Recordset = rs
    
    rs.Count = 0
    Erase rs.Record
    
    'Rückgabe
    GetNextRecordset = 1
  Else
    'Rückgabe
    'GetNextRecordset = 0
  End If
  
End Function