AW: Auch eine funktionierende Variante ...
12.12.2019 09:42:02
Dieter(Drummer)
Hallo Bernd,
Code in ein Modul:
'http://www.ms-office-forum.net/forum/showthread.php?t=187426, von Citizen X, 20.11.2011, 15:02
'Suchwort im Spaltenbereich färben
'Änderungen von Herber: von Michael (migre) am 18.10.2017
Sub Suchwortfärben()
Dim strText As String, intFound As Integer
Dim Zelle As Range
Dim Regex As Object, iItems, myItems
Dim lcolor As Long
'mx
If MsgBox("Im Spaltenbereich wird" & vbCrLf & "Wort/Zahl gefärbt nach folgender" & _
" Farbauswahl.", vbInformation + vbYesNo) = vbNo Then Exit Sub
Application.ScreenUpdating = False
strText = InputBox("Bitte Suchbegriff eingeben", "Suchbegriff")
If Trim(strText) = vbNullString Then Exit Sub
'von Michael (migre) am 18.10.2017 16:51:47
If Application.Dialogs(xlDialogEditColor).Show(10, 0, 125, 125) = True Then
lcolor = ActiveWorkbook.Colors(10)
Else
MsgBox "Farbauswahl abgebrochen!", , "Abbruch"
Exit Sub
End If
'Ende_ von Michael (migre) am 18.10.2017
Set Regex = CreateObject("Vbscript.Regexp")
With Regex
.Global = True
.IgnoreCase = True
.Pattern = strText
On Error GoTo ErrExit
For Each Zelle In Columns(Selection.Column).SpecialCells(xlCellTypeConstants)
Set iItems = .Execute(Zelle)
For Each myItems In iItems
With Zelle.Characters(myItems.firstIndex + 1, myItems.Length)
'.Font.Superscript = True 'Mx: Text hochstellen
.Font.Color = lcolor 'Mx: Farbe frei wählbar von: von Michael (migre) am 18.10. _
2017 16:51:47
End With
Next
Next
End With
ErrExit:
Set Regex = Nothing
End Sub
Gruß, Dieter(Drummer)