Option Explicit
Sub zeilen_in_spalten()
' Variablen deklarieren
Dim iZeile As Integer ' Zeilenanzahl der Adresse
Dim vArre As Variant ' Array Ausgangsdaten
Dim vArra() As Variant ' Array transponierte Daten
Dim iSzahl As Integer ' Schleifenzähler
Dim iSzaehler As Integer ' Schleifenzähler Ausgangsdaten
Dim iAnz As Integer ' Schleifenzähler 1. Arrayfeld transponierte Daten
Dim iFeld As Integer ' Schleifenzähler 2. Arrayfeld transponierte Daten
' Daten einlesen
On Error GoTo Fehler ' Fehler abfangen
iZeile = InputBox _
("Wieviele Zeilen hat der einzelne Datensatz?") ' Parameter abfragen
If IsEmpty(iZeile) Then Exit Sub ' wenn kein Werte eingegeben, dann Ausstieg
 If Not IsNumeric(iZeile) Then ' wenn keine Zahl eingegeben, dann ...
 MsgBox "Bitte eine Zahl eingeben" ' ... Meldung ausgeben
 Exit Sub ' ... Ausstieg
End If ' Ende der Bedingung
vArre = Selection ' markierten Bereich in Array
' Falsche Eingabe abfangen
If UBound(vArre) Mod iZeile <> 0 Then ' wenn Anzahl markierte Zeilen nicht ohne Rest
 ' durch Zeilen des Einzeldatensatz teilbar, dann ...
 MsgBox _
 "Bitte Eingabe überprüfen," & Chr(10) & _
 "Zeilenzahl passt nicht zur Markierung" ' ... Fehlermeldung ausgeben
 Exit Sub ' ... Ausstieg
End If ' Ende der Bedingung
ReDim vArra(UBound(vArre) / iZeile, iZeile) ' Dimension an Liste anpassen
' Liste neu gliedern
For iSzahl = LBound(vArre) To UBound(vArre) / iZeile ' "äußere" Schleife
 For iFeld = 0 To iZeile - 1 ' "innere" Schleife (Arrayfelder)
 iSzaehler = iSzaehler + 1 ' Zähler plus 1
 vArra(iAnz, iFeld) = vArre(iSzaehler, 1) ' Array mit transponierten Daten füllen
 Next iFeld ' Schleifenzähler plus 1
 If iSzaehler Mod iZeile = 0 Then iAnz = iAnz + 1 ' wenn "Zeile" im Array gefüllt, dann Feldzähler plus 1
Next iSzahl ' Schleifenzähler plus 1
' Neue Tabelle anlegen
ThisWorkbook.Worksheets.Add ' Tabellenblatt zufügen
Range("B3", Cells(UBound(vArre) / _
iZeile + 3, iZeile + 1)) = vArra ' Daten in Tabelle schreiben
' Liste formatieren
With Range("B1", Cells(UBound(vArre) / _
iZeile + 3, iZeile + 1)) ' Bereich definieren
 .WrapText = False ' kein Zeilenumbruch
 .EntireColumn.AutoFit ' optimale Spaltenbreite
End With ' Ende der Definition
Exit Sub ' Fertig - nicht in die Fehlerbehandlung laufen
' Fehlerbehandlung
Fehler: ' bei Fehler ...
 MsgBox Err.Description ' ... Meldung ausgeben
End Sub