Zelleninhalt untereinander

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub ttx() Dim arrTmp1, arrTmp2, arrTmp3() Dim i As Long, j As Integer, n As Long ReDim arrTmp3(1 To 4, 1 To 1) arrTmp1 = Range(Cells(2, 1), Cells(Rows.Count, 1).End(xlUp).Offset(0, 4)) For i = 1 To UBound(arrTmp1) arrTmp2 = Split(Left(arrTmp1(i, 4), Len(arrTmp1(i, 4)) - 1), ";") For j = 0 To UBound(arrTmp2) n = n + 1 ReDim Preserve arrTmp3(1 To 4, 1 To n) arrTmp3(1, n) = arrTmp1(i, 1) arrTmp3(2, n) = arrTmp1(i, 2) arrTmp3(3, n) = arrTmp1(i, 3) arrTmp3(4, n) = arrTmp2(j) & ";" Next j Next i Sheets(2).Cells(2, 1).Resize(n, 4) = WorksheetFunction.Transpose(arrTmp3) End Sub

Option Explicit Sub Unter() Dim lngZ As Long, arrQ, arrE(), lngM As Long, zz As Long, arrS, lngE As Long Dim pp As Long, ii As Long lngZ = Cells(Rows.Count, 4).End(xlUp).Row arrQ = Application.Transpose(Range(Cells(2, 1), Cells(lngZ, 4)).Value) lngM = 2 * lngZ ReDim arrE(1 To 4, 1 To lngM) For zz = 1 To lngZ - 1 arrS = Split(arrQ(4, zz), ";") For pp = 0 To UBound(arrS) - 1 lngE = lngE + 1 If lngE > lngM Then lngM = lngM + lngZ ReDim Preserve arrE(1 To 4, 1 To lngM) End If For ii = 1 To 3 arrE(ii, lngE) = arrQ(ii, zz) Next ii arrE(4, lngE) = arrS(pp) & ";" Next pp Next zz ReDim Preserve arrE(1 To 4, 1 To lngE) Sheets(2).Cells(2, 1).Resize(lngE, 4) = Application.Transpose(arrE) End Sub

Hallo,
kein Problem. Daten werden auf neue Tabellenblätter geschrieben:


Sub ttx()
Dim arrTmp1, arrTmp2, arrTmp3()
Dim i As Long, j As Integer, n As Long, wks As Worksheet
ReDim arrTmp3(1 To 4, 1 To 1)
arrTmp1 = Range(Cells(2, 1), Cells(Rows.Count, 1).End(xlUp).Offset(0, 4))
For i = 1 To UBound(arrTmp1)
arrTmp2 = Split(Left(arrTmp1(i, 4), Len(arrTmp1(i, 4)) - 1), ";")
For j = 0 To UBound(arrTmp2)
n = n + 1
ReDim Preserve arrTmp3(1 To 4, 1 To n)
arrTmp3(1, n) = arrTmp1(i, 1)
arrTmp3(2, n) = arrTmp1(i, 2)
arrTmp3(3, n) = arrTmp1(i, 3)
arrTmp3(4, n) = arrTmp2(j) & ";"
Next j
If n = Rows.Count - 1 Then
Set wks = Worksheets.Add
wks.Cells(2, 1).Resize(n, 4) = WorksheetFunction.Transpose(arrTmp3)
n = 0
ReDim arrTmp3(1 To 4, 1 To 1)
End If
Next i
Set wks = Worksheets.Add
wks.Cells(2, 1).Resize(n, 4) = WorksheetFunction.Transpose(arrTmp3)
End Sub

Gruß
Rudi
P.S. Im Forum gilt ausschließlich das Du

Sub ttx() Dim arrTmp1, arrTmp2, arrTmp3() Dim i As Long, j As Integer, k As Integer, n As Long, wks As Worksheet ReDim arrTmp3(1 To 4, 1 To 1) Application.ScreenUpdating = False arrTmp1 = Range(Cells(2, 1), Cells(Rows.Count, 1).End(xlUp).Offset(0, 19)) For i = 1 To UBound(arrTmp1) arrTmp2 = Split(Left(arrTmp1(i, 4), Len(arrTmp1(i, 4)) - 1), ";") For j = 0 To UBound(arrTmp2) n = n + 1 ReDim Preserve arrTmp3(1 To 4, 1 To n) For k = 1 To 3 arrTmp3(k, n) = arrTmp1(i, k) Next k arrTmp3(4, n) = arrTmp2(j) & ";" For k = 5 To 20 arrTmp3(k, n) = arrTmp1(i, k) Next k Next j If n = Rows.Count - 1 Then Set wks = Worksheets.Add wks.Cells(2, 1).Resize(n, 20) = WorksheetFunction.Transpose(arrTmp3) n = 0 ReDim arrTmp3(1 To 4, 1 To 1) End If Next i Set wks = Worksheets.Add wks.Cells(2, 1).Resize(n, 20) = WorksheetFunction.Transpose(arrTmp3) Application.ScreenUpdating = True End Sub

Sub ttx() Dim arrTmp1, arrTmp2, arrTmp3() Dim i As Long, j As Integer, k As Integer, n As Long, wks As Worksheet ReDim arrTmp3(1 To 20, 1 To 1) Application.ScreenUpdating = False arrTmp1 = Range(Cells(2, 1), Cells(Rows.Count, 1).End(xlUp).Offset(0, 19)) For i = 1 To UBound(arrTmp1) arrTmp2 = Split(Left(arrTmp1(i, 4), Len(arrTmp1(i, 4)) - 1), ";") For j = 0 To UBound(arrTmp2) n = n + 1 ReDim Preserve arrTmp3(1 To 20, 1 To n) For k = 1 To 3 arrTmp3(k, n) = arrTmp1(i, k) Next k arrTmp3(4, n) = arrTmp2(j) & ";" For k = 5 To 20 arrTmp3(k, n) = arrTmp1(i, k) Next k Next j If n = Rows.Count - 1 Then Set wks = Worksheets.Add wks.Cells(2, 1).Resize(n, 20) = WorksheetFunction.Transpose(arrTmp3) n = 0 ReDim arrTmp3(1 To 20, 1 To 1) End If Next i Set wks = Worksheets.Add wks.Cells(2, 1).Resize(n, 20) = WorksheetFunction.Transpose(arrTmp3) Application.ScreenUpdating = True End Sub

Beliebteste Forumthreads (12 Monate)

16 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

16
Beiträge zum Forumthread

Beiträge zu diesem Forumthread