Ok, das könnte es vermutlich schon sein:
Option Explicit
Sub ZeilenAufsplitten()
Dim wksQuelle As Excel.Worksheet
Dim wksZiel As Excel.Worksheet
Dim rngQuelle As Excel.Range
Dim d As Variant, z As Variant
Dim r As Long, c As Long
Dim i As Long, j As Long
Dim strT As String
Dim zmax As Long
Set wksQuelle = Tabelle1 'von hier werden die Daten genommen
Set wksZiel = Tabelle2 'hier landen die Daten
wksZiel.UsedRange.Clear 'Zielort leeren
Set rngQuelle = wksQuelle.UsedRange
'in diesem Datenfeld wird sich die maximal vorkommende
'Zeilenanzahl (in die aufzusplitten ist) gemerkt
ReDim z(1 To 2, 1 To rngQuelle.Columns.Count)
j = 1 'Zeilenindex im Zielort (dort wird angefangen zu schreiben)
'Zeilenweise durch die Datenquelle arbeiten...
For r = 1 To rngQuelle.Rows.Count
'Um aktuelle Zeile aufsplitten zu können, bringen wir u.a.
'die maximal notwendige Zeilenanzahl in Erfahrung
zmax = 0
For c = 1 To rngQuelle.Columns.Count
z(2, c) = Split(rngQuelle.Cells(r, c).Text, vbLf) 'Zeichenkette -> Array
z(1, c) = UBound(z(2, c)) + 1 'Zeilenanzahl
If z(1, c) > zmax Then zmax = z(1, c) 'max. Zeilenanzahl
Next
'jetzt schreiben wir die Daten - aufgesplittet - an ihren Zielort
For c = 1 To rngQuelle.Columns.Count
For i = 0 To z(1, c) - 1
With wksZiel.Cells(j + i, c)
If IsNumeric(Trim(z(2, c)(i))) Then
.Value = "'" & Trim$(z(2, c)(i))
Else
.Value = Trim$(z(2, c)(i))
End If
End With
Next
Next
j = j + zmax 'für den nächsten Durchlauf den Zeilenindex hochzählen
Next
End Sub
|