Hallo Zusammen,
hier im Forum habe ich von JoWE ein VBA-Scrpt bekommen, das eigentlich super läuft, aber noch 3 Probleme hat. Vielleicht kann mir noch ein Spezialist helfen, da ich als VBA-Anfänger das Script nicht verstehe, geschweige denn, ändern kann.
Die Probleme kommen daher, weil ich meine Definitionen nicht sauber genug gestellt hatte - mea culpa.
Aufgabenstellung:
Aus Zellen einer Spalte, in der gerade der Cursor steht, die den Begriff "DIN" enthalten, soll das Wort, das den Teilstring "DIN" enthält inklusive des folgenden Wortes, soweit es ein weiteres wort gibt, in die benachbarte Zelle rechts übertragen werden.
Hier die Beispiele mit den gewünschten Ergebnissen:
1 - "Strukturteil DIN4711A" -> "DIN4711A"
2 - "Strukturteil DIN-4711A test" -> "DIN-4711A"
3 - "xxx DIN 123 xxx" -> "DIN 123"
4 - "din 345" -> "din 345"
5 - "DIN 123 xxx" -> "DIN 123"
6 - "DIN-123 xxx" -> "DIN-123"
7 - "xxx DIN123" ->"DIN123"
8 - "DIN123 " "->"DIN123"
9 - "xxx DIN-123/XX xxx" ->DIN-123/XX"
10 - "xxx DIN/ISO 781 xxx" ->DIN/ISO 781"
11 - "hallo" -> leer
12 - "DIN 789" -> "DIN 789"
Probleme im nachfolgenden Script:
1. Beispiel 11: Sobald eine Zelle den Begriff "DIN" nicht enthält, kommt eine Fehlermeldung, statt dass die zelle übersprungen wird
2. Beispiel 4 funktioniert nicht, weil nicht alles Großbuchstaben sind, es sollte auch bei kleinen Buchstaben und gemischter Schreibweise funktionieren
3. Beispiel 12: Sobald hinter dem 2. Wort kein Leerzeichen ist, funktioniert es nicht
Vielleicht kann mir jemand helfen, im Anhang das bisherige Script
Mit freundlichen Grüßen
Hans
------------------------
Sub extrahiere_DINISO()
Dim i As Long, c As Long
Dim sh As Worksheet
c = ActiveCell.Column
Set sh = ActiveSheet
With sh
For i = ActiveCell.Row To .Cells(.Rows.Count, c).End(xlUp).Row
Cells(i, c + 1) = Mid(Cells(i, c), InStr(1, .Cells(i, c), "DIN"), 99)
If InStr(1, Cells(i, c + 1), " ") > 0 Then
Cells(i, c + 1) = Left(Cells(i, c + 1), InStr(InStr(1, Cells(i, c + 1), _
NumberExtract(CStr(Cells(i, c + 1)))) + 2, Cells(i, c + 1), " "))
End If
Next
End With
End Sub
-----------------------------
Function NumberExtract(ByVal strData As String, Optional ByVal lngPos As Long = 1) As Double
'Dank an Office-Loesung.de (Autor: Phelan XLPH)
Dim i As Long, strNumber As String, blnNumber As Boolean
For i = 1 To Len(strData)
If IsNumeric(Mid$(strData, i, 1)) Then
strNumber = strNumber & Mid$(strData, i, 1)
blnNumber = True
ElseIf blnNumber Then
strNumber = strNumber & ";"
blnNumber = False
End If
Next
NumberExtract = CDbl(Split(strNumber, ";")(lngPos - 1))
End Function