AW: So geht die Farbe raus klappt auch --))
26.09.2010 16:38:02
Tino
Hallo,
isch würde es demnach so machen.
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
Gruß Tino