VBA Textteile finden, ausschneiden in andere Zelle einfügen

[Klaus]

Excel 2007
VBA Kenntnisse: Wenig

Guten Abend ins Forum,

ich bin neu hier und hoffe ich wahre entsprechend den Regeln die Form  :17:

Ich versuche mich an einer Tabelle mit 5000+ Einträgen. 
Diese enthält die Spalte "D" in welcher ein Text steht.

Dieser Text enthält bis zu drei unterschiedliche Textpassagen die sich in (fast) jeder Zelle wiederfinden.

Ich möchte nun diese Textpassagen in den Zellen der Spalte "D" finden, diese ausschneiden (oder gegen "" ersetzen) und in die Spalte "F" übertragen.

Konkret:
"BUS" und/oder "BAHN" und/oder "AUTO" soll in der Spalte gefunden werden und dann zusammen in der nebenliegenden Zelle in "F" aufgeführt werden. Der restliche Text der Spalte "D" soll unverändert dort verbleiben.
Fehlen diese Textpassagen soll in die nebenliegende Zelle in "F" ein "X" geschrieben werden.
Es könnten auch komplett andere Spalten oder Hilfsfelder benutzt werden. Hauptsache es klappt irgendwie.


Jetzt habe ich so etwas hier schon ergattern können. Das würde zumindest einen Teil von dem gewünschten erreichen. 
Aber der Rest zusammenzustricken übersteigt mein Wissen  :16:

Code:

Sub ZeichenTauschen()
On Error Resume Next
Dim Zelle As Range
Dim SuchenNach As String
Dim ErsetzenDurch As String
SuchenNach = "BUS"
ErsetzenDurch = ""
For Each Zelle In Intersect(ActiveSheet.UsedRange, Range("D:D"))
Zelle.Value = Application.Substitute(Zelle.Value, SuchenNach, ErsetzenDurch)
 Next Zelle
On Error GoTo 0
End Sub

Könnte mir vielleicht jemand hilfreich unter die Arme greifen?

Vielen Dank
Klaus

[Fennek]

Hallo Klaus,

teste diesen Code:

Code:

Sub Fen()
lr = cells(rows.count, "D").end(xlup).row
Mob = array("Bus", "Bahn", "Auto")
for i = 2 to lr
    Tr = "x"
    for each Mo in Mob
        if instr(cells(i,"D"), Mo) > 0 then Tr = Mo
    next Mo
    cells(i, "F") = Tr
    cells(i,"D").replace(Tr, "")
next i
End Sub

mfg

[Klaus]

Guten Abend Fennek,

besten Dank für Deine Hilfe.

In dem Code wird diese Zeile rot markiert:

Code:

cells(i,"D").replace(Tr, "")

was kann ich tun?

Liebe Grüße
Klaus

[Fennek]

versuche

Code:

y = cells(i,"D").replace(Tr, "")

oder

Code:

cells(i,"D") = replace(cells(i,"D", Tr, "")

[Klaus]

Hallo Fennek,

im Grunde funktioniert das so.

Code:

y = Cells(i, "D").Replace(Tr, "")

half.

Aber - wenn man den code einmal ausführt, wird der Text korrekt aus "D" gelöscht und in "F" eingefügt.
Aber nur einer der drei Begriffe.
jetzt müsste man denselben Code nocheinmal ausführen...
Dann überschreibt er aber den eben in "F" eingefügten Begriff mit "x" da er ja in "D" nicht mehr vorhanden ist...


Was kann man da tun?

Liebe Grüße
Klaus

[Fennek]

Der Code plant nicht ein, dass mehrere der drei Begriffe in einer Zelle stehen können. Dazu wäre ein komplet anderer Ansatz nötig.

[Klaus]

oh... schade.... dann muss ich wohl über Umwege gehen und den schon übertragenen Teil einmal weiter kopieren und das alles dann am Ende verketten?
würde vielleicht gehen...

ich danke Dir aber für den Ansatz schon. 
Auch wenn ich keinen Schimmer habe was die Buchstaben zu bedeuten haben   :16:
...hab ich ja noch nie gesehen so einen Code  :19:

[Fennek]

ungeprüft:

Code:

Sub Fen()
lr = cells(rows.count, "D").end(xlup).row
Mob = array("Bus", "Bahn", "Auto")
for i = 2 to lr
   Tr = "x"
   for each Mo in Mob
       if instr(cells(i,"D"), Mo) > 0 then cells(i,"F") = cells(i, "F") & ", " & Mo
    y = cells(i,"D").replace(Mo, "")
   next Mo
   if cells(i, "F") = "" then cells(i, "F") = "x"
next i
end sub

[Fennek]

#7 kam ein paar Sekunden zu spät ...

[atilla]

Hallo,

von mir auch eine ähnliche Lösung:

Code:

Sub ZeichenTauschen()
Dim lngZ As Long, i As Long, j As Long
Dim Zelle As Range
Dim SuchenNach
Dim ErsetzenDurch As String
SuchenNach = Array("BUS", "Bahn", "Auto")
ErsetzenDurch = ""
lngZ = Cells(Rows.Count, 4).End(xlUp).Row

For i = 1 To lngZ
 For j = LBound(SuchenNach) To UBound(SuchenNach)
   If InStr(Cells(i, 4).Value, SuchenNach(j)) Then
     Cells(i, 6).Value = SuchenNach(j)
     Cells(i, 4).Value = Application.Substitute(Cells(i, 4).Value, SuchenNach(j), ErsetzenDurch)
   End If
Next j
Next i

End Sub

Wenn mehrere Begriffe in einem Satz vorkommen, dann muss das Auflisten in F angepasst werden.