Suchen - Ersetzen mit Bedingung | HERBERS Excel Forum

Hallo zusammen,
ich habe zwei unterschiedliche Strings, die Artikelbezeichnungen darstellen.
Nun soll je nach Artikeltyp, die Zeichenkette wie folgt extrahiert und in die gleiche Zelle geschrieben werden:
Typ 1:
004055238 04FG13 ABC; PPP Auftragsnr. Schraubendr. --> 055238
Typ 2:
004S_2356-68 ART - Schraubendreher 210 --> S_2356-68
Für Typ 1 habe ich bereits ein Makro. Jedoch wird der Typ 2 auch so ausgeschnitten, ohne dass der Stringtyp ermittelt wird. Wie kann ich eine Wenn-Dann Bedingung aufstellen, so dass je nach Typ der String richtig extrahiert wird?
Für Typ 1 sieht das so aus:


Set r = Intersect(Range("A:A"), ActiveSheet.UsedRange)
If Not r Is Nothing Then
For Each c In r
If c.Value  "" And Len(c.Value) > 10 Then _
c.Value = "'" & Right(Left(c.Value, InStr(c.Value, " ") - 1), 4)
Next
Else
MsgBox "Not Exists"
End If

Jetzt brauche ich noch eine Wenn-Dann-Bedingung, welche den Unterschied zwischen den beiden Typen macht sowie den Code für die Extraktion aus Typ 2.
Ich hoffe, dass mein Problem verständlich ist.
Anbei eine Beispiel-Datei mit Dummy-Daten.
https://www.herber.de/bbs/user/109776.xlsx
Die Strings die extrahiert werden sollen, habe ich Dick-Markiert.

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Versuch() Dim Regex As Object Dim objMatch As Object Dim zelle As Range For Each zelle In Selection '---ausgewaehlte Zellen Set Regex = CreateObject("Vbscript.Regexp") With Regex .Pattern = "((S_)\d+(-)\d+ |\d+ )" .Global = True Set objMatch = .Execute(zelle) If objMatch.Count > 0 Then 'prüft ob Pattern enthalten MsgBox IIf(Left(objMatch(0).Value, 1) = "S", objMatch(0).Value, Right(objMatch(0).Value, _ 5)) End If End With Next End Sub

If c "" And Len(c) > 10 Then If Mid(c, 4, 1) = "S" Then '--pruefen ob S in Text an 4.Stelle c = Mid(c, InStr(1, c, "S"), InStr(c, " ") - 3) Else c = "'" & Right(Left(c, InStr(c, " ") - 1), 4) End If End If

Sub Test() Dim r As Range, c As Range With Sheets("Tabelle1") Set r = Intersect(Range("A:A"), ActiveSheet.UsedRange) If Not r Is Nothing Then For Each c In r If Mid(c, 4, 1) = "S" Then c = Mid(c, InStr(1, c, "S"), InStr(c, " ") - 3) Else c = "'" & Right(Left(c, InStr(c, " ") - 1), 4) End If Next Else MsgBox "Keine gefunden" End If

Dim r As Range, c As Range With Sheets("Aufträge")' "" And Len(c) > 10 Then If Mid(c, 4, 1) = "S" Then c = Mid(c, InStr(1, c, "S"), InStr(1, c, " ") - 3) Else c = "'" & Right(Left(c, InStr(1, c, " ") - 1), 4) End If End If Next Else MsgBox "Keine gefunden" End If End With

Beliebteste Forumthreads (12 Monate)

Suchen - Ersetzen mit Bedingung

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

305 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Suchen - Ersetzen mit Bedingung

8 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)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread