Dim p As Long, x As Range, sp As Range
Set sp = ActiveSheet.Range("...")
For Each x In sp
p = Instr(x, "###")
If CBool(p) Then _
x.Characters(p, 3).Font.Color = vbRed
Next x
Sub DreiRautenRotFaerbenLucUndNoNet()
Dim lngStelle As Long, rngBereich As Range, rngZelle As Range
Set rngBereich = ActiveSheet.Range("A1:D10").SpecialCells(xlCellTypeConstants, 2)
For Each rngZelle In rngBereich
lngStelle = 0
Do
lngStelle = InStr(lngStelle + 1, rngZelle, "###")
If CBool(lngStelle) Then _
rngZelle.Characters(lngStelle, 3).Font.Color = vbRed
Loop Until lngStelle = 0
Next
End Sub
Dim p As Long, x As Range, sp As Range
Set sp = ActiveSheet.Range("...")
For Each x In sp
p = Instr(x, "###")
If CBool(p) Then
While p > 0
x.Characters(p, 3).Font.Color = vbRed
p = Instr(p + 3, x, "###")
Wend
End If
Next x
Sub faerben()
Dim Zelle As Range
Dim strStart As String
Const cSuch = "###" 'ggf.anpassen
With Range("H:H") ' Spalte anpassen
Set Zelle = .Find(What:="###", LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False)
If Zelle Is Nothing Then Exit Sub
strStart = Zelle.Address
Do
With Zelle.Characters(Start:=InStr(Zelle, cSuch), Length:=3).Font
.ColorIndex = 3
End With
Set Zelle = .FindNext(Zelle)
Loop Until Zelle.Address = strStart
End With
End Sub
Sub FarbeText(sZelle As Range, sBegriff As String, iColor As Integer, booCase As Boolean)
Dim objRegExp As Object, oMatch As Object
Set objRegExp = CreateObject("vbscript.regexp")
With objRegExp
.Global = True
.Pattern = sBegriff
.IgnoreCase = Not booCase
Set oMatch = .Execute(sZelle.Text)
End With
For Each oMatch In oMatch
sZelle.Characters(Start:=oMatch.FirstIndex + 1, Length:=oMatch.Length).Font.ColorIndex = iColor
Next oMatch
Set objRegExp = Nothing
End Sub
Sub Beispiel()
Dim Bereich As Range
'Bereich anpassen
Set Bereich = Range("A7", Cells(Rows.Count, 1).End(xlUp))
Bereich.Font.ColorIndex = xlAutomatic
For Each Bereich In Bereich
If Bereich.Text <> "" Then
'Zelle; Suchbegriff; Farbindex; Groß u. Kleinschreibung beachten True = Ja
FarbeText Bereich, "Hallo", 3, False
End If
Next Bereich
End Sub