Text finden (Fortsetzung)

Hallo EXCEL-Freunde,
benötige nochmals Hilfe:
habe aus dem Archiv einen Ansatz für eine Lösung, von Nepumuk und Dieter Klemke
bereits angepasst aber doch noch nicht ganz gelöst:
Ich habe in der Zelle A3 stehen:
WV 234 Muster Kaufen 462 T
Nun habe ich die Lösung, dass in einer Zelle der Name eingetragen wird:
Muster kaufen
Sub aaaTest() Dim anfText As Long Dim länText As Long Dim i As Long, j As Long Dim zf As String For j = 3 To 25 zf = Worksheets("Tabelle1").Cells(j, 1) ' Position des Blanks nach der 1. Zahl anfText = InStr(4, zf, " ") + 1 ' Anfang der 2. Zahl suchen For i = anfText To Len(zf) If IsNumeric(Mid$(zf, i, 1)) Then länText = i - 1 - anfText Exit For End If Next i Cells(j, 4) = Mid$(Cells(j, 1), anfText, länText) Next j 'MsgBox Mid$("zf, anfText, länText") End Sub
Normalerweise müssen die Zellen in Spalte A wie folgt erfasst werden:
1. WV
2. Leerstelle (Blank)
3. Zahl (2 bis 5-stellig)
4. Namen, Buchstaben (evtl. mit Leerstellen)
5. Leerstelle (Blank)
6. Zahlen
--> Ziel soll sein, nur die Namen, Buchstaben (=4.) anzuzeigen.
Leider führt der o.g. Code zu einem Abbruch, wenn von dieser Eingabe abgewichen wird; zB. bei "WV, 234 M...."
Nun sollte hier vielleicht dann eine Fehlermeldung in die Spalte 4 der
betreffenden Zeile eingetragen werden:
For i = anfText To Len(zf)
If IsNumeric(Mid$(zf, i, 1)) Then
länText = i - 1 - anfText
'Exit For
Else
If IsNotNumeric....?
End If
Next i
Hat jemand eine Idee?
Besten Dank für eine Hilfe!
mfg
Erich

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Hallo Erich,
jetzt habe ich die Sache angefangen, dann bringe ich sie vor dem Urlaub auch noch zu Ende.
Die Plausi-Prüfung ist recht aufwendig, wenn man alle möglichen Fehler abfangen will.
Hier mein Vorschlag:


Sub aaaTest()
Dim anfText As Long
Dim Fehlertext As String
Dim länText As Long
Dim i As Long, j As Long
Dim zf As String
For j = 3 To 25
zf = Worksheets("Tabelle1").Cells(j, 1)
If Not StringKorrekt(zf, Fehlertext) Then
Cells(j, 4) = Fehlertext
Else
' Position des Blanks nach der 1. Zahl
anfText = InStr(4, zf, " ") + 1
' Anfang der 2. Zahl suchen
For i = anfText To Len(zf)
If IsNumeric(Mid$(zf, i, 1)) Then
länText = i - 1 - anfText
Exit For
End If
Next i
Cells(j, 4) = Mid$(Cells(j, 1), anfText, länText)
End If
Next j
End Sub


Function StringKorrekt(Txt As String, _
Fehlertext As String) _
As Boolean
Dim BlankExist As Boolean
Dim i As Long
Dim posBlank As Long
Dim posZiff As Long
Dim ZiffGr2Da As Boolean
StringKorrekt = True
' 1. Beginnt der Text mit "WV "?
If Left$(Txt, 3) <> "WV " Then
Fehlertext = "FN 1: Text beginnt nicht mit 'WV '"
StringKorrekt = False
Exit Function
End If
' 2. Steht auf Stelle 4 eine Ziffer?
If Not IsNumeric(Mid$(Txt, 4, 1)) Then
Fehlertext = "FN 2: Auf Position 4 steht keine Ziffer"
StringKorrekt = False
Exit Function
End If
' 3. Folgt direkt nach der ersten Zifferngruppe ein Blank?
BlankExist = False
For i = 4 To Len(Txt)
If Not IsNumeric(Mid$(Txt, i, 1)) Then
If Mid$(Txt, i, 1) = " " Then
posBlank = i
BlankExist = True
End If
Exit For
End If
Next i
If Not BlankExist Then
Fehlertext = "FN 3: Nach der ersten Zifferngruppe folgt kein Blank"
StringKorrekt = False
Exit Function
End If
' 4. Folgt nach der ersten Zifferngruppe noch eine zweite ?
If posBlank = Len(Txt) Then
Fehlertext = "FN 4a: Keine 2. Zifferngruppe"
StringKorrekt = False
Exit Function
End If
' Nach der 1. Ziffer der 2. Zifferngruppe suchen
For i = posBlank + 1 To Len(Txt)
If IsNumeric(Mid$(Txt, i, 1)) Then
posZiff = i
ZiffGr2Da = True
Exit For
End If
Next i
If Not ZiffGr2Da Then
Fehlertext = "FN 4b: Keine 2. Zifferngruppe"
StringKorrekt = False
Exit Function
End If
' 5. steht vor der 2. Zifferngruppe ein Blank?
If Not Mid$(Txt, posZiff - 1, 1) = " " Then
Fehlertext = "FN 5: Vor der 2. Zifferngruppe steht kein Blank"
StringKorrekt = False
Exit Function
End If
End Function

Ab Sonntag bin ich nicht mehr da.
MfG
Dieter

Sub Test() ' aus Zelleninhalt Text zwischen Zahlen auslesen Cells(2, letzteSpalte + 2) = "Bezeichnung" Dim anfText As Long Dim länText As Long Dim j As Long, s As Long Dim zf As String Dim str As String '' falsche WV-Bezeichnung, alle Varianten For s = 3 To myZeile str = Cells(s, 1).Value If str Like "WV ## [A-z]*" Or str Like "WV ### [A-z]*" Or str Like "WV #### [A-z]*" Or str Like "WV ##### [A-z]*" Then 'Debug.Print "Richtig" zf = Worksheets(myName1).Cells(s, 1) 'j ' Position des Blanks nach der 1. Zahl anfText = InStr(4, zf, " ") + 1 ' Anfang der 2. Zahl suchen For i = anfText To Len(zf) If IsNumeric(Mid$(zf, i, 1)) Then länText = i - 1 - anfText Exit For End If Next i Cells(s, letzteSpalte + 2) = Mid$(Cells(s, 1), anfText, länText) Else Cells(s, letzteSpalte + 2) = Cells(s, 1) '"Fehler" Debug.Print "Falsch" End If Next s End Sub

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

169 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Text finden (Fortsetzung)

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

169 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