Einzelne Wörter in Zelle markieren

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo,
die Spalte und die Startzeile musst du dir selber anpassen:

Option Explicit

Public Sub Test()

    Dim objRegEx As Object, objMatch As Object
    Dim objCell As Range
    Dim strText As String
    Dim lngIndex As Long

    strText = InputBox("Bitte Keyword eingeben.", "Eingabe")

    If StrPtr(strText) <> 0 And Trim$(strText) <> vbNullString Then

        strText = Trim$(strText)

        Set objRegEx = CreateObject("VBScript.RegExp")

        With objRegEx

            .Global = True
            .IgnoreCase = True
            .Pattern = strText

            For Each objCell In Range(Cells(2, 1), Cells(Rows.Count, 1).End(xlUp)) 'Spalte 1 ab Zeile 2

                objCell.Font.Bold = False

                Set objMatch = .Execute(objCell.Text)

                For lngIndex = 0 To objMatch.Count - 1

                    With objCell.Characters(objMatch.Item(lngIndex).FirstIndex + 1, _
                            objMatch.Item(lngIndex).Length).Font

                        .Bold = True
                        .Color = vbRed

                    End With
                Next
            Next
        End With
    End If

    Set objMatch = Nothing
    Set objRegEx = Nothing

End Sub

Gruß
Nepumuk

Hallo,
dann so:

Option Explicit

Public Sub SetFontColorKeywordcells()

    Dim objRegEx As Object, objMatch As Object
    Dim objValueCell As Range, objKeywordCell As Range
    Dim lngIndex As Long

    With Range(Cells(2, 11), Cells(Rows.Count, 11).End(xlUp)).Font

        .Bold = False
        .Color = vbBlack

    End With

    Set objRegEx = CreateObject("VBScript.RegExp")

    With objRegEx

        .Global = True
        .IgnoreCase = True

        For Each objKeywordCell In Range(Cells(2, 13), Cells(2, Columns.Count).End(xlToLeft))

            .Pattern = objKeywordCell.Text

            For Each objValueCell In Range(Cells(2, 11), Cells(Rows.Count, 11).End(xlUp))

                Set objMatch = .Execute(objValueCell.Text)

                For lngIndex = 0 To objMatch.Count - 1

                    With objValueCell.Characters(objMatch.Item(lngIndex).FirstIndex + 1, _
                            objMatch.Item(lngIndex).Length).Font

                        .Bold = True
                        .Color = vbRed

                    End With
                Next
            Next
        Next
    End With

    Set objMatch = Nothing
    Set objRegEx = Nothing

End Sub

Eine Erweiterung der Keyword-Liste wird automatisch verarbeitet wenn du das Makro aufrufst.
Gruß
Nepumuk

Sub test() sb = "dick" l = Len(sb) For ze = 2 To 99 t = InStr(1, Cells(ze, 1), "dick") With Cells(ze, 1).Characters(Start:=t, Length:=l).Font .FontStyle = "Bold" .Color = RGB(255, 0, 0) .Color = vbRed End With Next End Sub

Sub test() sb = "dick" l = Len(sb) For ze = 2 To 600 t = InStr(1, Cells(ze, 11), "dick") With Cells(ze, 1).Characters(Start:=t, Length:=l).Font .FontStyle = "Bold" '.Color = RGB(255, 0, 0) .Color = vbRed End With Next End Sub

Sub test() sb = "dick" l = Len(sb) For ze = 2 To 600 t = InStr(1, Cells(ze, 11), "dick") With Cells(ze, 11).Characters(Start:=t, Length:=l).Font .FontStyle = "Bold" '.Color = RGB(255, 0, 0) .Color = vbRed End With Next End Sub

Beliebteste Forumthreads (12 Monate)

Einzelne Wörter in Zelle markieren

16
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

123 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Einzelne Wörter in Zelle markieren

16 Beiträge zum Forumthread Beiträge zu diesem Forumthread

123 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

16
Beiträge zum Forumthread

Beiträge zu diesem Forumthread