AW: Wort in Text suchen und hervorheben
18.02.2022 09:44:44
Nepumuk
Hallo Nathalie,
und noch eine Abfrage ob die Zelle leer ist.
Option Explicit
Public Sub Worte_markieren()
Dim lngRow As Long, lngPosition As Long, lnglastRow As Long
Dim lngIndex As Long, lngPercent As Long
Dim strText As String, strFirsAddress As String
Dim objCell As Range
With Worksheets("Tabelle1")
With .Range(.Cells(3, 4), .Cells(.Rows.Count, 6).End(xlUp)).Font
.Color = vbBlack
.Bold = False
End With
lnglastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
lngPercent = CLng(100 / (lnglastRow - 2))
For lngRow = 3 To .Cells(.Rows.Count, 1).End(xlUp).Row
lngIndex = lngIndex + lngPercent
Application.StatusBar = " " & CStr(lngIndex) & " % " & String$(lngIndex \ 2, ChrW$(9609))
If Not IsEmpty(.Cells(lngRow, 1).Value) Then
strText = .Cells(lngRow, 1).Text
Set objCell = .Columns("D:F").Find(What:=strText, _
LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)
If Not objCell Is Nothing Then
strFirsAddress = objCell.Address
Do
lngPosition = InStr(1, objCell.Text, strText, vbTextCompare)
With objCell.Characters(lngPosition, Len(strText)).Font
.Color = vbRed
.Bold = True
End With
Set objCell = .Columns("D:F").FindNext(After:=objCell)
Loop Until objCell.Address = strFirsAddress
Set objCell = Nothing
End If
End If
Next
End With
Application.StatusBar = False
End Sub
Gruß
Nepumuk