Hallo,

ich habe mal etwas vorbereitet, hoffe es trifft die Problematik. Als Ziel für die transponierten Daten wird hier ein eigenes Arbeitsblatt gewünscht, kann man natürlich noch in 'Range' abändern.

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") 'Startpunkt/-zelle
  bCopyHeader = True  'Kopfzeile soll mitkopiert werden (wenn möglich)
  rid = 2             'abs. Zeilenindex für Beginn erster Datensatz (Kopfzeile ist damit: rid-1)
  
  'erster Datensatz vorhanden?
  bRecordset = Len(Trim(rng.Text)) > 0
  While bRecordset
    
    'die Einträge des Datensatzes durchwandern
    'und in rngRS "merken"
    Set rngRS = Nothing
    'ist ein Eintrag vorhanden?
    bEntry = Len(Trim(rng.Offset(ColumnOffset:=1).Text)) > 0
    While bEntry
      
      'Eintrag dem Datensatz zuordnen
      ' Ein Eintrag besteht aus einem Bezeichner
      ' und einem Wert (d.h. umfasst 2 Spalten)
      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
      
      'nächster Eintrag
      Set rng = rng.Offset(RowOffset:=1)
      'ist ein Eintrag vorhanden?
      bEntry = Len(Trim(rng.Offset(ColumnOffset:=1).Text)) > 0
    Wend
    
    If Not rngRS Is Nothing Then
    'an Zielort kopieren
    '(es wird hier davon ausgegangen, dass die Anzahl
    ' und Reihenfolge der Variablen immer die gleiche ist)
      
      If bCopyHeader Then
        bCopyHeader = False
        If rid > 1 Then 'Platz für Kopfzeile vorhanden?
          'Kopfzeile (einmalig) kopieren (transponiert)
          rngRS.Columns(1).Copy
          Destination.Rows(rid - 1).PasteSpecial xlPasteValues, Transpose:=True
        End If
      End If
      
      'Datensatz kopieren (transponiert)
      rngRS.Columns(2).Copy
      Destination.Rows(rid).PasteSpecial xlPasteValues, Transpose:=True
      
      'den animierten Kopierrahmen deaktivieren
      Application.CutCopyMode = False
      
      'Zeile für nächsten Datensatz
      rid = rid + 1
      'Anzahl der kopierten Datensätze
      n = n + 1
    End If
    
    'zwischen zwei Datensätzen gibt es noch eine leere Zeile
    'die hiermit übergangen wird
    Set rng = rng.Offset(RowOffset:=1)
    'ist ein weiterer Datensatz vorhanden?
    bRecordset = Len(Trim(rng.Text)) > 0
  Wend
  
  'Anzahl der kopierten Datensätze zurückgeben
  transpRecordsets = n
  
End Function