AW: Suchmakro
16.11.2009 18:05:11
Josef
Hallo Karsten,
probier's mal so. (Achte auf den Code, der in's Modul der Tabelle1 gehört!)
' **********************************************************************
' Modul: Tabelle1 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address(0, 0) = "B1" Then Set rng = Nothing
End Sub
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Public rng As Range
Public rngBereich As Range
Sub finde_Inhalt_in_B_ab_heute()
'deklarationen gehören an den Anfang der Prozedur!
Dim varRes As Variant
Dim unterkante_1 As Range
Dim Zeile1 As Long
On Error GoTo ErrExit
Application.EnableEvents = False
With ActiveSheet
If rng Is Nothing Then
varRes = Application.Match(Clng(Date), .Range("A:A"), 0)
If IsNumeric(varRes) Then
Application.Goto Cells(varRes, ActiveCell.Column)
ActiveWindow.ScrollRow = ActiveCell.Row - 1
Set rngBereich = .Range(Cells(varRes, 2), .Cells(Rows.Count, 2))
Set rng = rngBereich.Find(What:=.Cells(1, 2), LookIn:=xlValues, LookAt:=xlPart, After:=rngBereich.Cells(rngBereich.Rows.Count, 1))
End If
Else
Set rng = rngBereich.Find(What:=.Cells(1, 2), LookIn:=xlValues, LookAt:=xlPart, After:=rng)
End If
If Not rng Is Nothing Then
Application.Goto rng
Set unterkante_1 = ActiveWindow.VisibleRange
If ActiveCell.Row = unterkante_1.Row + unterkante_1.Rows.Count - 1 Or ActiveCell.Row = unterkante_1.Row + unterkante_1.Rows.Count - 2 Then
Zeile1 = ActiveCell.Row
rng.WrapText = True
If Not Intersect(ActiveCell, unterkante_1) Is Nothing Then
ActiveWindow.ScrollRow = WorksheetFunction.Max(1, Zeile1 - unterkante_1.Rows.Count / 1.2)
End If
End If
Einfaerben_rot
Else
MsgBox "nada!"
GoTo ErrExit
End If
End With
ErrExit:
Application.EnableEvents = True
End Sub
' **********************************************************************
' Modul: Modul2 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub Einfaerben_rot()
Dim iLaenge As Integer
Dim iPosit As Integer
With ThisWorkbook.Worksheets("Tabelle1")
iLaenge = Len(ActiveCell)
ActiveCell.Characters(Start:=1, Length:=iLaenge).Font.ColorIndex = xlAutomatic
If .Range("B1").Value <> "" Then
iPosit = InStr(LCase(ActiveCell), LCase(.Range("B1").Value))
If iPosit > 0 Then
iLaenge = Len(.Range("B1").Value)
ActiveCell.Characters(Start:=iPosit, Length:=iLaenge).Font.ColorIndex = 3
End If
End If
End With
End Sub
Gruß Sepp