02.02.2018, 15:04
@Wastl
noch eine Variante, auch nicht perfekt, aber kompakt genug um per Hand zu prüfen:
(Falls es eine ähnliche Aufgabe noch einmal geben sollte, hilft es hoffenlich)
noch eine Variante, auch nicht perfekt, aber kompakt genug um per Hand zu prüfen:
Code:
Sub Wastl()
Dim DD As Object
Ar = ActiveSheet.UsedRange.Columns(1)
Set DD = CreateObject("Scripting.dictionary")
With CreateObject("vbscript.regexp")
.Global = True
.IgnoreCase = False
.MultiLine = False
For i = 2 To UBound(Ar)
.Pattern = "ab\s|bis\s|im\s|in\s|mit\s|ohne\s|zu\s|und\s|für\s"
If .test(Ar(i, 1)) Then
Tx = iClean(CStr(Ar(i, 1)))
y = DD(Tx)
Cells(i, 1).Interior.Color = vbYellow
End If
Next i
For i = 2 To UBound(Ar)
.Pattern = "[A-Za-zäöüÄÖÜ][a-zäöü]{2,}"
If .test(Ar(i, 1)) Then y = DD(CStr(.Execute(Ar(i, 1))(0)))
Next i
Cells(1, 3).Resize(DD.Count) = Application.Transpose(DD.keys)
End With
End Sub
Function iClean(ByVal Tx As String) As String
Pt = Array("l/min", "\dml", "\d{2,4}\s{0,1}cm", "\dH\d", "°C", "\d{2,4}W", _
"\dx\d", "\sx\s", "\d{1,3}kW", "\d+\s{0,1}lt", "\d{1,4}\s{0,1}mm", _
"\d{2}HZ", "\d{2,3}V\b", "\d{2,3}er", "\d{2,3}m2", "\dt", _
"\.{0,1}\d{1,3}m", "\dkg", "\dm3/h", "\d+m\s", "[Ø<>°+()-/=""]", "\d", _
"\.x")
With CreateObject("vbscript.regexp")
.Global = True
.IgnoreCase = False
For a = 0 To UBound(Pt)
.Pattern = Pt(a)
If .test(Tx) Then
Tx = .Replace(Tx, "")
End If
Next a
End With
iClean = Trim(Tx)
End Function(Falls es eine ähnliche Aufgabe noch einmal geben sollte, hilft es hoffenlich)
