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
Set
wksZiel = Tabelle2
wksZiel.UsedRange.Clear
Set
rngQuelle = wksQuelle.UsedRange
ReDim
z(1
To
2, 1
To
rngQuelle.Columns.Count)
j = 1
For
r = 1
To
rngQuelle.Rows.Count
zmax = 0
For
c = 1
To
rngQuelle.Columns.Count
z(2, c) = Split(rngQuelle.Cells(r, c).Text, vbLf)
z(1, c) = UBound(z(2, c)) + 1
If
z(1, c) > zmax
Then
zmax = z(1, c)
Next
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
Next
End
Sub