Thema: String markieren | Herbers Excel-Forum

Hallo Forum,
Spalte C6:C200 werden Wetter Daten importiert.
Z.B. steht in
Zelle C59:
TAF LEBL 100500Z 1006/1106 35014KT 9999 FEW030 TX18/1015Z TN08/1006Z TEMPO 1010/1018 24012KT=
Zelle C63:
TAF LFPG 100500Z 1006/1112 24005KT BECMG 1108/1110 18005KT 9999 BKN012 TX09/1014Z TNM03/1006Z=
U.s.w.
Ich habe für C59 String TN08 (heisst Temperatur Minimum 08°) markiert
Für C63 String TNM03 (Temperatur Min. -03°) markiert.
Nun soll natürlich alles was mit TNM20 bis TN04 (-20° bis +4°) der String in rot+fett markiert werden.
TN05 bis TN40 (+5° bis +40°) soll in schwarz fett markiert werden.
Dank im Voraus
Gruss
mehmet

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

Hallo Tino,
super, ich Danke Dir.
Es funktionier.
Herzliche Grüsse
mehmet

Sorry Tino,
kure Frage noch bitte
Kann man
Public Sub InStrString(ByVal strString$, ByRef objMatch As Object)
in den Sub TextHervorheben() einbauen.
Damit habe ich dann ein Macro (Macro ausführen) an Auswahl statt wie hier zwei.
Herzlichen Dank nochmal
Gruss
mehmet

Hallo,
kannst mal testen ob so auch geht, sollte eigendlich funktionieren.

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

Gruß Tino

Super, klappt
Dank Dir
Gruss
mehmet