String markieren

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

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

Sub TextHervorheben() Dim Zelle As Range Dim objMatch As Object Dim iIndex As Integer, iColor As Integer Dim sngWert As Single, booFont As Boolean Dim Regex As Object Set Regex = CreateObject("Vbscript.Regexp") With Regex .IgnoreCase = False .MultiLine = True .Pattern = "(TNM|TN)\d{1,4}" .Global = True End With 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 Set objMatch = Regex.Execute(Zelle.Text) 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 Set Regex = Nothing Application.ScreenUpdating = True End Sub

Beliebteste Forumthreads (12 Monate)

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread