Code zum testen
03.12.2015 09:41:59
Tino
Hallo,
kannst mal diese Variante testen.
Bin mal davon ausgegangen das die Daten ab A1:B1 stehen.
Die Ausgabe erfolgt zum testen ab C1!
Option Explicit
Sub Start()
Dim ArData, NewAr()
Dim ArStringA, ArStringB
Dim n&, j&, i&, ii&
'Datenbereich hier ab A1
With Tabelle1
ArData = Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 2)
End With
Redim Preserve NewAr(1 To 2, 1 To Ubound(ArData))
For n = 1 To Ubound(ArData)
If ArData(n, 1) <> "" Then
ArStringA = Split(ArData(n, 1), vbLf)
For j = Lbound(ArStringA) To Ubound(ArStringA)
i = i + 1
If Ubound(NewAr, 2) < i Then Redim Preserve NewAr(1 To 2, 1 To i)
NewAr(1, i) = ArStringA(j)
Next j
End If
If ArData(n, 2) <> "" Then
ArStringB = Split(ArData(n, 2), vbLf)
For j = Lbound(ArStringB) To Ubound(ArStringB)
ii = ii + 1
If Ubound(NewAr, 2) < ii Then Redim Preserve NewAr(1 To 2, 1 To ii)
NewAr(2, ii) = ArStringB(j)
Next j
End If
If i > ii Then ii = i
If ii > i Then i = ii
Next n
Call TransposeArray(NewAr)
'Ausgabe der Daten hier ab C1
With Tabelle1
.Range("C1").Resize(Ubound(NewAr), Ubound(NewAr, 2)) = NewAr
End With
End Sub
Sub TransposeArray(ArArray)
Dim NewAr()
Dim n&, nn&, j&, jj&
Redim Preserve NewAr(1 To Ubound(ArArray, 2) - Lbound(ArArray, 2) + 1, _
1 To Ubound(ArArray) - Lbound(ArArray) + 1)
For n = Lbound(ArArray) To Ubound(ArArray)
j = j + 1
For nn = Lbound(ArArray, 2) To Ubound(ArArray, 2)
jj = jj + 1
NewAr(jj, j) = ArArray(n, nn)
Next nn
jj = 0
Next n
ArArray = NewAr
End Sub
Gruß Tino