VBA - Text in Spalten, dann untereinander Zeilen einfügen und Werte transponieren

Hallo Florian,
wenn deine Werte ab A1 nach unten stehen, dann füge davor eine Spalte ein und lass dir die getrennten Werte (in der neuen Spalte A) untereinander ausgeben:

Sub Transponieren()

Dim LRow As Long

Dim myArr As Variant

Dim arrTemp As Variant

Dim i As Long, j As Long

With ActiveSheet

LRow = .Cells(.Rows.Count, 1).End(xlUp).Row

myArr = .Range("A1:A" & LRow)

.Columns(1).Insert

j = 1

For i = 1 To UBound(myArr)

arrTemp = Split(myArr(i, 1), ", ")

.Cells(j, 1).Resize(UBound(arrTemp) + 1) = Application.Transpose(arrTemp)

j = j + UBound(arrTemp) + 1

Next

End With

End Sub

Claus

Hallo Claus,
Textteilen-Funktion geht bei mir nicht, ist das eine Funktion für neuere Excel-Version?
Würde das aus allen Zellen einen langen Text machen und dann wieder in Einzelteile zerteilen?
Werden dadurch neue Zeilen generiert?
MfG

Der Ansatz, wie dieses Problem zu lösen ist, bedingt ein weiteres Problem... Warum Zeilen einfügen?
Wenn es nur darum geht die einzelnen Werte untereinander in eine Spalte zu bekommen ist es mit VBA viel einfacher diese zu sammeln und zum Schluss in das Blatt "zu schütten".
Und es gibt noch eine einfache Lösung mit Power Query (ab 2010 als Add-in, ab 2016 ist es eingebaut). Das kann auch ähnlich wie "Text in Spalten" und dann ein entpivotieren.
So oder so, mit beiden Techniken gibt es zusätzlich noch die Möglichkeit weitere Daten die in anderen Spalten stehen könnten mitzuführen und entsprechend der Kennziffern aufzuführen.
Wenn Du ein konkretes Beispiel möchtest dann müsste ich Deine (Beispiel-) Datei sehen.
Andreas.

Hallo AnnaThomas,
vielen Dank für die schnelle Rückmeldung.
Ich vermute aufgrund der automatischen Übersetzung haben sich ein paar Fehler eingeschlichen...
So wie der Code jetzt ist kommt eine Benachrichtigung : Anwendungs- oder objektdefinierter Fehler.
Code:
Sub TransposeData()
Dim lastRow As Long, i As Long, j As Long
Dim srcRange As Range, destRange As Range, cell As Range

Set srcRange = Range("A1:A7").CurrentRegion
For i = 2 To srcRange.Rows.Count
lastRow = srcRange.Cells(i, Columns.Count).End(x1toLeft).Split
For j = 1 To lastRow
Rows(i + 1).Insert
Set destRange = Cells(i + 1, j)
Set cell = Cells(i, j)
destRange.Value = WorksheetFunction.Transpose(cell.Value)
Next j
i = i + 1
Next i

End Sub
Irgendwelche Fehler? Range("A1:A7") wäre dann schon angepasst an meine Testdatei.

Hallo Andreas,
danke für den Tipp, kannte ich bis dato noch nicht. Hab´s gleich mal ausprobiert und funktioniert super!
Vielen Dank.