Korrektur etwas vergessen !!!!!!
20.06.2008 20:25:00
Tino
Sub Test()
Dim A As Long
Dim Bereich As Range, SBereich As Range, strAdress$
Application.ScreenUpdating = False
Set Bereich = Range("B2:B10000") 'Suchbereich
Bereich.Offset(0, 3).Font.Underline = xlNone
For A = 1 To 10000
If A = 1 Then
Set SBereich = Bereich.Find(What:="*", After:=Bereich(1), LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False)
If Not SBereich Is Nothing Then
strAdress$ = SBereich.Address
SBereich.Offset(0, 3).Font.Underline = xlUnderlineStyleDouble
Else
Exit For
End If
Else
Set SBereich = Bereich.FindNext(After:=SBereich)
If SBereich.Address strAdress And Not SBereich Is Nothing Then
SBereich.Offset(0, 3).Font.Underline = xlUnderlineStyleDouble
Else
Exit For
End If
End If
Next A
Application.ScreenUpdating = True
End Sub