Suchen nach Zeichen und Zeilen verdoppeln

Hallo !
ich hoffe Ihr könnt mir helfen. Ich habe folgendes Problem, ich habe eine Excel Tabelle mit folgender Struktur:
Feld1                        Feld2
Text1:Text2:Text3   TextTextTextText
In der Excel Tabelle sind natürlich mehrere von diesen Zeilen. Ich muss nun folgendes machen. In Feld 1 sind mehrere kurze Texte durch einen Doppelpunkt getrennt. Ich muss nun in einer Art Schleife zunächst erkennen ob in Feld 1 so ein Doppelpunkt vorhanden ist, wenn ja, dann soll Text2 in eine neue Zeile verschoben schoben, der Inhalt von Feld2 soll dann ebenfalls in das Feld2 der neuen Zeile verschoben werden. Das gleiche soll dann auch mit Text3 passieren, also ebenfalls eine neue Zeile. Die Anzahl der "Textschnipsel" in Feld1 kann von Zeile zu Zeile variieren.
Es sollte also folgendes herauskommen:
Feld1                        Feld2
Text1                        TextTextTextText
Text2                        TextTextTextText (dies ist eine neue Zeile)
Text3                        TextTextTextText (dies ist eine neue Zeile)
Lässt sich so etwas mit einem Makro erledigen ?
Bin Euch für jede Hilfe dankbar!
Viele Grüsse
Tom

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub test() Dim rng As Range Dim i As Integer With Sheets("Tabelle1") For Each rng In .Range("A1:A" & .Cells(Rows.Count, 1).End(xlUp).Row) Do Until (i = 0 And InStr(1, rng, ":") = 0) Or _ (i > 0 And InStr(1, rng.Offset(i, 0), ":") = 0) i = i + 1 rng.Offset(i, 0).EntireRow.Insert rng.Offset(i, 1) = rng.Offset(0, 1) rng.Offset(i, 0) = Right(rng.Offset(i - 1, 0), Len(rng.Offset(i - 1, 0)) _ - InStr(1, rng.Offset(i - 1, 0), ":")) rng.Offset(i - 1, 0) = Left(rng.Offset(i - 1, 0), _ InStr(1, rng.Offset(i - 1, 0), ":") - 1) Loop Next 'rng End With End Sub

Sub test() Dim rng As Range Dim i As Integer With Sheets("Tabelle1") For Each rng In .Range("A1:A" & .Cells(Rows.Count, 1).End(xlUp).Row) Do Until (i = 0 And InStr(1, rng, ":") = 0) Or _ (i > 0 And InStr(1, rng.Offset(i, 0), ":") = 0) i = i + 1 rng.Offset(i, 0).EntireRow.Insert rng.Offset(i, 1) = rng.Offset(i - 1, 1) rng.Offset(i, 0) = Right(rng.Offset(i - 1, 0), Len(rng.Offset(i - 1, 0)) _ - InStr(1, rng.Offset(i - 1, 0), ":")) rng.Offset(i - 1, 0) = Left(rng.Offset(i - 1, 0), _ InStr(1, rng.Offset(i - 1, 0), ":") - 1) Loop Next 'rng End With End Sub

Hallo Tom,
ich habe dir das Makro mal für insgesamt 4 Spalten angepasst. Zwischen den Doppelkreuzen musst du einfach für jede weitere Spalte eine weitere Codezeile einfügen und in dieser Codezeile den Spaltenindex immer um 1 erhöhen, so wie ich das für die zwei weiteren Spalten bereits gemacht habe.


Sub test()
Dim rng As Range
Dim i As Integer
With Sheets("Tabelle1")
For Each rng In .Range("A1:A" & .Cells(Rows.Count, 1).End(xlUp).Row)
Do Until (i = 0 And InStr(1, rng, ":") = 0) Or _
(i > 0 And InStr(1, rng.Offset(i, 0), ":") = 0)
i = i + 1
rng.Offset(i, 0).EntireRow.Insert
rng.Offset(i, 1) = rng.Offset(i - 1, 1)
rng.Offset(i, 2) = rng.Offset(i - 1, 2)
rng.Offset(i, 3) = rng.Offset(i - 1, 3)
rng.Offset(i, 0) = Right(rng.Offset(i - 1, 0), Len(rng.Offset(i - 1, 0)) _
- InStr(1, rng.Offset(i - 1, 0), ":"))
rng.Offset(i - 1, 0) = Left(rng.Offset(i - 1, 0), _
InStr(1, rng.Offset(i - 1, 0), ":") - 1)
Loop
Next 'rng
End With
End Sub

Gruß Ingolf

Beliebteste Forumthreads (12 Monate)

Suchen nach Zeichen und Zeilen verdoppeln

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

305 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Suchen nach Zeichen und Zeilen verdoppeln

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

305 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread