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
Die erweiterte Suchfunktion hilft dir, gezielt die besten Antworten zu finden
Suche nach den besten AntwortenEntdecke unsere meistgeklickten Beiträge in der Google Suche
Top 100 Threads jetzt ansehen