VBA Zeileninhalt auf 2 Zeilen aufteilen

Hallo liebe VBA-Experten,
mit der Schleifenprogrammierung tue ich mir noch ein bisschen schwer, daher möchte ich mein Problem kurz schildern. Ich möchte in einer Excel-Datei (Tabelle1) Zeile für Zeile abarbeiten und diese in Tabelle 2 in je 2 Zeilen aufsplitten.
Beispiel: Ausgangsbasis Tabelle 1 Zeile1 ( Werte aus Spalte A, B u. C) sollen nach Tabelle 2
in die Zeile 1 (Spalte A,B u. C) kopiert werden. Die Spalten D,E u. F Zeile 1 aus Tabelle 1 soll in die Spalten A,B u. C) in die Zeile 2 der Tabelle 2 kopiert werden. Werte aus Zeile 2 (Spalte A,B u. C) aus Tabelle 1 dann in die Zeile 3 (A,B u. C) in Tabelle 2 kopieren. Werte aus Spalte D,E u. F Zeile 2 aus Tabelle 1 soll in die Spalten A,B u. C) in die Zeile 4 der Tabelle 2 kopiert werden usw. bis die letzte Zeile aus Tabelle 1 erreicht ist.
Über Ihren VBA-Vorschlag freue ich mich
Viele Grüße
FCK_Fan

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Hi Fan,
probier mal


Option Explicit
Sub Aufteile()
Dim lngQ As Long, lngC As Long, arQ, arZ(), zz As Long, cc As Long
Const cTeile As Long = 2
With Sheets("Tabelle1")
lngQ = LetzteZeileInBereich(.Columns("A:F"))
zz = lngQ Mod cTeile
If zz > 0 Then lngQ = lngQ + cTeile - zz
lngC = LetzteSpalteInBereich(.Columns("A:F"))
zz = lngC Mod cTeile
If zz > 0 Then lngC = lngC + cTeile - zz
arQ = .Cells(1, 1).Resize(lngQ, lngC)
End With
ReDim arZ(1 To lngQ * cTeile, 1 To lngC / cTeile)
For zz = 1 To UBound(arZ)
For cc = 1 To UBound(arZ, 2)
arZ(zz, cc) = arQ(1 + Int((zz - 1) / cTeile), _
cc + lngC / cTeile * ((zz - 1) Mod cTeile))
Next cc
Next zz
With Sheets("Tabelle2")
.Cells.ClearContents
.Cells(1, 1).Resize(UBound(arZ), UBound(arZ, 2)) = arZ
End With
End Sub
Function LetzteZeileInBereich(rngB As Range) As Long
Dim rng As Range
With rngB
Set rng = .Find("*", .Cells(1, 1), xlValues, , xlByRows, xlPrevious)
If rng Is Nothing Then
LetzteZeileInBereich = .Cells(1, 1).Row
Else
LetzteZeileInBereich = rng.Row
End If
End With
End Function
Function LetzteSpalteInBereich(rngB As Range) As Long
Dim rng As Range
With rngB
Set rng = .Find("*", .Cells(1, 1), xlValues, , xlByColumns, xlPrevious)
If rng Is Nothing Then
LetzteSpalteInBereich = .Cells(1, 1).Column
Else
LetzteSpalteInBereich = rng.Column
End If
End With
End Function

Ohne VBA gehts einfacher (Formel von A1 nach rechts und unten kopieren):

	A	B	C
1	war A1	war B1	war C1
2	war D1	war E1	war F1
3	war A2	war B2	war C2
4	war D2	war E2	war F2
5	war A3	war B3	war C3
6	war D3	war E3	war F3
7	war A4	war B4	war C4
8	war D4	war E4	war F4
9	war A5	war B5	war C5
10	war D5	war E5	war F5
11	war A6		war C6
12	war D6		war F6
13	war A7
14	0
15	war A8
16	0
17	war A9
18	0
19	war A10
20	0
21

Formeln der Tabelle

Zelle	Formel
A1	=WENN(ZEILE()>2ANZAHL2(Tabelle1!A:A); ""; INDEX(Tabelle1!$A$1:$F$10;(ZEILE()+1)/2;SPALTE()+3REST(ZEILE()+1;2)))

Rückmeldung wäre nett! - Grüße aus Kamp-Lintfort von Erich

Option Explicit Option Base 1 Sub Übertrag() Dim Val1, Val2, i&, n%, k& With Sheets("Tabelle1") Val1 = Intersect(.UsedRange, .Columns("A:C")).Value Val2 = Intersect(.UsedRange, .Columns("D:F")).Value End With ReDim Out(UBound(Val1) + UBound(Val2), 3) For i = 1 To UBound(Val1) k = k + 1 For n = 1 To 3 Out(k, n) = Val1(i, n) Next n k = k + 1 For n = 1 To 3 Out(k, n) = Val2(i, n) Next n Next Sheets("Tabelle2").Range("A1").Resize(UBound(Val1) + UBound(Val2), 3) = Out End Sub

Dim x&, z&, rng As Range Application.ScreenUpdating = False x = 1 z = 1 For Each rng In Range("Bereich") Tabelle2.Cells(x, z) = rng z = z + 1 If z = 4 Then z = 1 x = x + 1 End If Next Application.ScreenUpdating = True

Option Explicit Sub Aufteile2() Dim lngQ As Long, lngC As Long, arQ, arZ(), qz As Long, qc As Long Dim zz As Long, zc As Long Const spQ As Long = 6 Const spZ As Long = 3 With Sheets("Tabelle1") lngQ = LetzteZeileInBereich(.Columns("A:F")) arQ = .Cells(1, 1).Resize(lngQ, spQ) End With ReDim arZ(1 To Application.RoundUp(lngQ * spQ / spZ, 0), 1 To spZ) zz = 1 For qz = 1 To lngQ For qc = 1 To spQ If zc >= spZ Then zz = zz + 1: zc = 1 Else zc = zc + 1 arZ(zz, zc) = arQ(qz, qc) Next qc Next qz With Sheets("Tabelle2") .Cells.ClearContents .Cells(1, 1).Resize(UBound(arZ), spZ) = arZ End With End Sub Function LetzteZeileInBereich(rngB As Range) As Long Dim rng As Range With rngB Set rng = .Find("*", .Cells(1, 1), xlValues, , xlByRows, xlPrevious) If rng Is Nothing Then LetzteZeileInBereich = .Cells(1, 1).Row Else LetzteZeileInBereich = rng.Row End If End With End Function

Sub Aufteile2() Dim lngQ As Long, arQ, arZ(), qz As Long, qc As Long Dim zz As Long, zc As Long Const spQ As Long = 6 ' Spaltenzahl der Quelle Const spZ As Long = 5 ' Spaltenzahl des Ziels With Sheets("Tabelle1") lngQ = LetzteZeileInBereich(.Range(.Columns(1), .Columns(spQ))) arQ = .Cells(1, 1).Resize(lngQ, spQ) End With ReDim arZ(1 To Application.RoundUp(lngQ * spQ / spZ, 0), 1 To spZ) zz = 1 For qz = 1 To lngQ For qc = 1 To spQ If zc

Beliebteste Forumthreads (12 Monate)

VBA Zeileninhalt auf 2 Zeilen aufteilen

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

306 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

VBA Zeileninhalt auf 2 Zeilen aufteilen

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

306 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread