Text mehrfach hervorheben

Private Sub CommandButton1_Click() Dim rng As Range Dim cell As Range Dim start_str As Integer Set rng = Worksheets("Sheet1").Range("a7:f1000") 'Reset Color to Black Range("a7:f1000").Select Selection.Font.ColorIndex = 0 Selection.Font.Bold = False 'myword = InputBox("Enter the search string ") Set myword = Worksheets("Sheet1").Range("A1") Mylen = Len(myword) For Each cell In rng start_str = InStr(cell.Value, myword) If start_str Then cell.Characters(start_str, Mylen).Font.ColorIndex = 3 End If Next Range("a1").Select End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Private Sub CommandButton1_Click() Dim rng As Range, cell As Range, Pos As Integer, myWord As String Dim myLen As Integer Set rng = Worksheets("Sheet1").Range("a7:f1000") 'Reset Color to Black rng.Font.ColorIndex = 0 rng.Font.Bold = False 'myword = InputBox("Enter the search string ") myWord = Worksheets("Sheet1").Range("A1") myLen = Len(myWord) For Each cell In rng Pos = 0 While InStr(Pos + 1, cell.Value, myWord) Pos = InStr(Pos + 1, cell.Value, myWord) cell.Characters(Pos, myLen).Font.ColorIndex = 3 Wend Next Range("a1").Select End Sub

Hi.
Habe es ein wenig umgearbeitet.


Private Sub CommandButton1_Click()
Dim rnG As Range
Dim ceLL As Range
Dim start_Str As Integer
Dim myWord As String
Dim myLen As Integer
Dim firstCell As String
Application.ScreenUpdating = False
Set rnG = Worksheets("Tabelle3").Range("a7:e26") 'Worksheets("Sheet1").Range("a7:f1000")
'Reset Color to Black
With rnG
.Font.ColorIndex = 0
.Font.Bold = False
End With
'myword = InputBox("Enter the search string ")
myWord = UCase(Worksheets("Tabelle3").Range("A1"))
myLen = Len(myWord)
Set ceLL = rnG.Find(myWord)
If Not ceLL Is Nothing Then
firstCell = ceLL.Address
start_Str = 0
Do
start_Str = 0
start_Str = InStr(start_Str + 1, UCase(ceLL.Value), myWord)
While start_Str > 0
ceLL.Characters(start_Str, myLen).Font.ColorIndex = 3
start_Str = InStr(start_Str + myLen + 1, UCase(ceLL.Value), myWord)
Wend
Set ceLL = rnG.FindNext(ceLL)
Debug.Print (ceLL.Address)
Loop Until ceLL Is Nothing Or firstCell = ceLL.Address
End If
Range("a1").Select
Application.ScreenUpdating = True
End Sub

Gruss, Jogy

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Text mehrfach hervorheben

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread