Makro, das Texte in andere Zellen einfügt

Hallo,
ich bitte euch um Hilfe.
Ihr würdet mir wirklich wahnsinnig die Arbeit erleichtern.
Was ich mir vorstelle ist,
1. Ich füge Texte in Spalte A ein. In der Regel 96 Texte, in ganz wenigen Ausnahmefällen auch mal weniger, auf keinen Fall mehr.
2. Ich möchte, den 1. 4. 7. 10. usw. Text in Spalte B auflisten
3. Und den 2. 5. 8. 11. usw. Text in Spalte C. Bei den Texten in Spalte C soll es jedoch noch eine Besonderheit geben, in den meisten Fällen steht in diesen Texten eine Jahreszahl in Klammern. Wenn dem der Fall ist, soll der Text danach enden. Alles was nach der Jahreszahl kommt, soll nicht in Spalte C übernommen werden.
Und danach soll Spalte A wieder geleert werden.
Hier noch eine kleine Vorschau was ich meine:
Ich hoffe es ist verständlich
https://www.herber.de/bbs/user/131482.xlsx
Viele Grüße
Christian

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hi Christian,
ich nehme an, dass die Jahreszahl in Klammern immer an letzter Stelle steht falls mehrmals Daten in Klammern vorkommen und dass neue Daten unterhalb der zuletzt übertragenen angefügt werden sollen?

Sub Uebertragen()
Dim lngZeile As Long
Dim lngZiel As Long
If Application.CountA(Columns(1)) > 0 Then
If Application.CountA(Columns(4)) > 0 Then
lngZiel = Columns(4).Find(What:="*", SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row + 1
Else
lngZiel = 1
End If
For lngZeile = 2 To Columns(1).Find(What:="*", SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row Step 3
Cells(lngZiel, 2) = Cells(lngZeile - 1, 1)
If InStrRev(Cells(lngZeile, 1), ")") > 0 Then
Cells(lngZiel, 3) = Left(Cells(lngZeile, 1), InStrRev(Cells(lngZeile, 1), ")"))
Else
Cells(lngZiel, 3) = Cells(lngZeile, 1)
End If
lngZiel = lngZiel + 1
Next lngZeile
End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range) Dim lngZeile As Long Dim lngZiel As Long If Target.Cells(1).Column = 1 Then If Application.CountA(Columns(1)) > 0 Then If Application.CountA(Columns(3)) > 0 Then lngZiel = Columns(3).Find(What:="*", SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious).Row + 1 Else lngZiel = 1 End If For lngZeile = 3 To Columns(1).Find(What:="*", SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious).Row Step 3 Cells(lngZiel, 2) = Cells(lngZeile - 1, 1) If InStrRev(Cells(lngZeile, 1), ")") > 0 Then Cells(lngZiel, 3) = Left(Cells(lngZeile, 1), _ InStrRev(Cells(lngZeile, 1), ")")) Else Cells(lngZiel, 3) = Cells(lngZeile, 1) End If lngZiel = lngZiel + 1 Next lngZeile Columns(1).ClearContents End If End If End Sub

Beliebteste Forumthreads (12 Monate)

Makro, das Texte in andere Zellen einfügt

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

321 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Makro, das Texte in andere Zellen einfügt

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

321 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