Sub Rot_raus()
Dim i As Long
For i = 4 To ActiveSheet.Range("B4:B65000").End(xlDown).Row
If ActiveSheet.Range("B" & i).Cells.Font.ColorIndex = 3 Then
ActiveSheet.Range("B" & i).Cells.Font.ColorIndex = 1
End If
Next i
End Sub
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ArrayArgumente
Dim i As Integer
Dim rngBereich As Range, rngTmp As Range
'Farbe festlegen
Const IntFarbe As Integer = 3 'Farbe anpassen
'wo soll der Code wirken
Set rngBereich = Range("B4:B" & Rows.Count) 'Bereich anpassen
'Target nicht im wirkungsbereich? --> Abbruch
If Intersect(rngBereich, Target) Is Nothing Then Exit Sub
ArrayArgumente = Array("Stuhl", "Tisch") 'Argumente entsprechend anpassen
'Suchen ausführen um ersetzen auf gesamter Mappe abzuschalten
Cells(Rows.Count, Columns.Count).Find ""
With Application
'Bildschirm einfrieren
.ScreenUpdating = False
'Events abstellen
.EnableEvents = False
rngBereich.Interior.ColorIndex = xlColorIndexNone
For i = Lbound(ArrayArgumente) To Ubound(ArrayArgumente)
Set rngTmp = Suche_(rngBereich, ArrayArgumente(i))
If Not rngTmp Is Nothing Then _
rngTmp.Interior.ColorIndex = IntFarbe
Next i
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Private Function Suche_(rngBereich As Range, ByVal SuchText As String) As Range
Dim rngRange As Range, rngTemp As Range, strErste As String
Set rngRange = rngBereich.Find(SuchText, LookIn:=xlValues, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False)
If Not rngRange Is Nothing Then
strErste = rngRange.Address
Set rngTemp = rngRange
Set rngRange = rngBereich.FindNext(rngRange)
Do While strErste <> rngRange.Address
Set rngTemp = Union(rngTemp, rngRange)
Set rngRange = rngBereich.FindNext(rngRange)
Loop
Set Suche_ = rngTemp
End If
End Function
| A | B | C | D | E | |
| 2 | Der Stuhl steht im Keller | Suchtext | - > | stuhl | |
| 3 | Stuh | ||||
| 4 | Stul | ||||
| 5 | Stuhlbein |
| Bedingte Formatierungen der Tabelle | |||||||||||||||
|
Sub www()
Dim i As Long
For i = 4 To ActiveSheet.Range("B4:B65000").End(xlDown).Row
If ActiveSheet.Range("B" & i).Value = "Stuhl" Then
ActiveSheet.Range("B" & i).Font.ColorIndex = 3
End If
Next i
End Sub
ActiveSheet.Columns(2).Font.ColorIndex = xlAutomatic
Private Sub Worksheet_Change(ByVal Target As Range)
Const strBegriff As String = "Stuhl"
Dim rngCell As Range, rngFuellbereich As Range
Set rngFuellbereich = Intersect(Target, Range("B4:B65536"))
If rngFuellbereich Is Nothing Then Exit Sub
For Each rngCell In Fuellbereich
Select Case rngCell.Value
Case strBegriff
rngCell.Font.ColorIndex = 3
Case Else
rngCell.Font.ColorIndex = xlAutomatic
End Select
Next rngCell
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