meinst Du so?
10.11.2009 12:13:26
Tino
Hallo,
versuche es mal so, in der Select Case kann der Bereich eingestellt werden.
Public Sub InStrString(ByVal strString$, ByRef objMatch As Object)
Dim Regex As Object
Set Regex = CreateObject("Vbscript.Regexp")
With Regex
.IgnoreCase = False
.MultiLine = True
.Pattern = "(TNM|TN)\d{1,4}"
.Global = True
Set objMatch = .Execute(strString)
End With
Set Regex = Nothing
End Sub
Sub TextHervorheben()
Dim Zelle As Range
Dim objMatch As Object
Dim iIndex As Integer, iColor As Integer
Dim sngWert As Single, booFont As Boolean
Application.ScreenUpdating = False
For Each Zelle In Range("C6:C200") 'Zellbereich angeben
If InStr(Zelle.Value, "TN") > 0 Then
With Zelle.Font
.ColorIndex = 0
.Bold = False
End With
InStrString Zelle.Text, objMatch
For iIndex = 0 To objMatch.Count - 1
If InStr(objMatch(iIndex), "TNM") > 0 Then
sngWert = Replace(objMatch(iIndex), "TNM", "-") * 1
Else
sngWert = Replace(objMatch(iIndex), "TN", "") * 1
End If
Select Case sngWert
'Wert liegt zwischen -20 und 4
Case -20 To 4: iColor = 3
Case Else: iColor = 1
End Select
With Zelle.Characters(objMatch(iIndex).FirstIndex + 1, Len(objMatch(iIndex))).Font
.ColorIndex = iColor
.Bold = True
End With
Next iIndex
Set objMatch = Nothing
End If
Next Zelle
Application.ScreenUpdating = True
End Sub
Gruß Tino