Texte zum Übersetzen finden

[Phi.VBA]

@Wastl

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)

[Wastl]

Hi Phil,

du bist unermüdlich

Danke, gugg ich mir die Tage mal an