ich möchte gern eine Spalte überprüfen.
Wenn z.b. in der Spalte ein Text steht: "Stuhl" dann sollte die Schrift ROT werden.
Vielleicht ein Makro was ich selbst mal ändern kann, z.b. eine bestimmte Zahl oder die
Zelle LEER ist etc.,
mfg walli
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
mfg walliOption 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
Gruß TinoA | 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
und es klappt !
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