AW: Markierten Zelleninhalt suchen wenn markiert?
30.10.2009 15:07:31
fcs
Hallo belanglos,
das folgende Makro prüft die Selektion einer Zelle in Spalte B und markiert den nächsten identischen Wert unter und oberhalb der selektierten Zelle.
Einfügen muss du das Makro im VBA-Editor unter dem Tabellenblatt-Modul.
Nicht vergessen vor dem Schliessen der Datei eine Zelle außerhalb Spalte 2 zu selektieren, da sonst die Farbkennung mit gespeichert wird, aber beim nächsten öffnen nicht automatisch rückgäng gemacht wird.
Gruß
Franz
Private LastUP As Range, LastDown As Range 'Merker für letzte Markierungen
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim varSuchen, rngUP As Range, rngDown As Range, Zelle As Range
Const ColorUP = 3 'rot
Const ColorDown = 6 'grün
Const PlusMinus = 20 'Anzahl Zellen ober- und unterhalb, die durchsucht werden.
With Target
'ggf. Zellfarben in Zellen der vorherigen Suche zurücksetzen
If Not LastDown Is Nothing Then
LastDown.Interior.ColorIndex = xlColorIndexNone
Set LastDown = Nothing
End If
If Not LastUP Is Nothing Then
LastUP.Interior.ColorIndex = xlColorIndexNone
Set LastUP = Nothing
End If
'Nummer der Spalte und Zeile prüfen und Wert in aktiver Zelle
If .Column = 2 And .Row > 1 And .Cells.Count = 1 And .Range("A1") "" Then
varSuchen = Target.Value
'Bereich oberhalb selektierter Zelle setzen
If .Row >= 1 + PlusMinus Then
Set rngUP = Range(.Offset(-PlusMinus, 0), .Offset(-1, 0))
Else
Set rngUP = Range(Cells(2, .Column), .Offset(-1, 0))
End If
'Bereich unterhalb selektierter Zelle setzen
Set rngDown = Range(.Offset(PlusMinus, 0), .Offset(0, 0))
'Bereich oberhalb nach Wert in selektierter Zelle durchsuchen
Set Zelle = rngUP.Find(what:=varSuchen, LookIn:=xlValues, lookat:=xlWhole, _
searchdirection:=xlPrevious)
If Zelle Is Nothing Then
Set LastUP = Nothing
Else
Zelle.Interior.ColorIndex = ColorUP
Set LastUP = Zelle
End If
'Bereich oberhalb nach Wert in selektierter Zelle durchsuchen
Set Zelle = rngDown.Find(what:=varSuchen, LookIn:=xlValues, lookat:=xlWhole, _
searchdirection:=xlNext)
If Zelle.Address = .Address Then
Set LastDown = Nothing
Else
Zelle.Interior.ColorIndex = ColorDown
Set LastDown = Zelle
End If
End If
End With
End Sub