Zeile kopieren und in gleiche Tab einfüg

Hallo zusammen!
Nachdem ich mir schon ein einen Wolf suche und leider kein Coding finde, das meinen Bedarf deckt, möchte ich euch um Hilfe ersuchen. Im Wesentlichen geht es darum innerhalb einer Tabelle Zeilen zu kopieren und in derselben Tabelle wieder einzufügen - aber nicht am Ende der Tabelle sondern mittendrin.
Folgende Anforderung
In einer Tabelle befinden sich n Zeilen welche in einer Spalte mit 0 - n beistrichgetrennten Texteinträgen befüllt sind
zB.: abcde-1962, abcde-1835, abcde-909
Ziel ist es nun, all jene Zeilen der Tabelle, in welchen in obenganannter Spalte mehr als ein Eintrag steht, zu kopieren und unmittelbar unterhalb der originalen Zeile einzufügen.
Darüber hinaus sollen am Ende soviiele Zeilen stehen, wie in der originalen Zeile Einträge in besagter Spalte waren. Und damit das noch kniffliger wird, soll in all den nun vorhandenen Zeilen (inklusive der originalen Zeile) in besagter Spalte nur noch jeweils einer der Einträge stehen.
Ich hätte - als nicht VBA gescillter - damit begonnen - erstellt von einem Unbekannten im Netz und etwas abgewandelt...
Option Explicit


Sub ZeileEinfuegen()
Dim i As Long
Application.ScreenUpdating = False
For i = Cells(Rows.Count, "N").End(xlUp).Row To 1 Step -1
If InStr(LCase(Cells(i, "N")), ",") > 0 Then
Cells(i, "N").EntireRow.Copy
Cells(i + 1, "N").EntireRow.Insert
End If
Next
Application.ScreenUpdating = False
End Sub

Nur, wie zerlege ich nun den Inhalt der Spalte so, dass jede Zeile nur noch einen Eintrag in dieser Spalte hat?
lg & Danke bereits im Voraus für eure Mühen!
Günter

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Liste() Dim rStart As Range Dim i As Long Dim Liste Dim Zeile Set rStart = Range("A3") 'Anpassen Liste = Application.Transpose(Range(rStart, rStart.End(xlDown))) For i = 1 To UBound(Liste) Zeile = Split(Liste(i), ",") rStart.Resize(UBound(Zeile) + 1) = Application.Transpose(Zeile) Set rStart = rStart.Offset(UBound(Zeile) + 1) Next i End Sub

Sub ListeSchnell() Dim rStart As Range Dim i As Long Dim j As Long Dim Liste Dim Zeile Dim ListeNeu() Set rStart = Range("A3") 'Anpassen Liste = Application.Transpose(Range(rStart, rStart.End(xlDown))) ReDim ListeNeu(0) For i = 1 To UBound(Liste) Zeile = Split(Liste(i), ",") ReDim Preserve ListeNeu(UBound(ListeNeu) + UBound(Zeile) + 1) For j = 0 To UBound(Zeile) ListeNeu(UBound(ListeNeu) - UBound(Zeile) - 1 + j) = Zeile(j) Next j Next i rStart.Resize(UBound(ListeNeu)) = Application.Transpose(ListeNeu) End Sub

Sub Trennen() Dim TB As Worksheet, LR As Long, i As Long, SP As Integer, Z1 As Integer, j As Integer, k As Integer Dim Arr 'anpassen**** Set TB = Sheets("Tabelle1") Z1 = 2 'Erste Zeile mit Daten; ggf. wegen Überschrift SP = 1 'Daten in Spalte A '*** With TB LR = .Cells(.Rows.Count, SP).End(xlUp).Row 'letzte Zeile der Spalte For i = LR To Z1 Step -1 k = Len(.Cells(i, SP)) - Len(Replace(.Cells(i, SP), ",", "")) 'Anzahl Kommas If k > 0 Then .Rows(i).Copy 'Zeilen kopieren und einfügen .Rows(i).Offset(1).Resize(k).Insert xlDown Application.CutCopyMode = False Arr = Split(.Cells(i, SP), ",") ' Trennen bei Komma For j = Lbound(Arr) To Ubound(Arr) ' Zählung beginnt mit 0 .Cells(i + j, SP) = Trim(Arr(j)) 'Aufgesplittete Werte eintragen (Leerzeichen vorher entfernen) Next j End If Next i End With End Sub

Beliebteste Forumthreads (12 Monate)

Zeile kopieren und in gleiche Tab einfüg

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread