Clever-Excel-Forum - VBA Textteile finden, ausschneiden in andere Zelle einfügen

Seiten: 1 2

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

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

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

versuche

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

oder

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

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...

Huh

Was kann man da tun?

Liebe Grüße
Klaus

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.

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:

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

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

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.

Seiten: 1 2