Bestimmte Wörter innerhalb einer Zelle rot einfärben

Hallo Michèle,

ändere einen Teil des Codes so ab:

With Sheets("Artikelliste")

   LRow = .Cells(.Rows.Count, 1).End(xlUp).Row

   For Each rngC In .Range("D2:D" & LRow)

      With rngC

         Set matches = re.Execute(rngC)

         If matches.Count > 0 Then

            For i = 0 To matches.Count - 1

               Start = matches.Item(i).FirstIndex + 1

               Laenge = matches.Item(i).Length

               .Characters(Start, Laenge).Font.Color = vbRed

            Next

         End If

      End With

   Next

Claus

Hallo Michèle,

probiere mal diesen Alternativ-Vorschlag:

Sub WortEinfaerben()

Dim rngC As Range, c As Range

Dim LRow As Long

Dim re, match, matches

Dim ptrn As String, firstaddress As String

Dim varData As Variant

Dim Start As Integer, Laenge As Integer
Set re = CreateObject("vbscript.regexp")

ptrn = "E\s[0-9]{3}[a-z]{0,1}"

re.Pattern = ptrn

re.Global = True
With Sheets("E Nr")

   LRow = .Cells(.Rows.Count, "B").End(xlUp).Row

   varData = .Range("B2:B" & LRow)

End With

With Sheets("Artikelliste")

   LRow = .Cells(.Rows.Count, 1).End(xlUp).Row

   For Each rngC In .Range("D2:D" & LRow)

      With rngC

         Set matches = re.Execute(rngC)

         If matches.Count > 0 Then

            For Each match In matches

               .Characters(InStr(rngC, match), Len(match)).Font.Color = vbRed

            Next

         End If

      End With

   Next

   For i = LBound(varData) To UBound(varData)

      Set c = .Range("D2:D" & LRow).Find(varData(i, 1), LookIn:=xlValues, lookat:=xlPart, MatchCase:=False)

      If Not c Is Nothing Then

         firstaddress = c.Address

         Do

            Start = InStr(1, c, varData(i, 1), 1)

            If Start > 0 Then

               Laenge = Len(varData(i, 1))

               c.Characters(Start, Laenge).Font.Color = vbRed

               Set c = .Range("D2:D" & LRow).FindNext(c)

            End If

         Loop While c.Address <> firstaddress

      End If

   Next

End With

End Sub

Claus

Hallo Michèle,

das ist schon klar, das liegt an der 2ten FOR-Schleife, das Split trennt den String an den Leerstellen auf.

Data = Split(Data)

For k = 0 To UBound(Data)

Key = Data(k)

If Dict.Exists(Key) Then

Und daher wird "Data(k)" niemals gefunden wenn dieses aus 2 oder mehreren Wörtern besteht.

Müsste ich mir mal Gedanken machen, im Prinzip müsste man diese Sonderfälle nochmals extra prüfen mit einem Extra-Dictionary...

Nun ja, die Hilfe hier im Forum ist ja generell kostenfrei, alles andere müssen wir dann per Mail besprechen, steht im meinem Profil.

Andreas.

Option Explicit

Sub ENummernEinfaerben()

  Dim R As Range

  Dim Data

  Dim i As Long, j As Long

  Dim Dict As Object 'Scripting.Dictionary

  Dim Key As String

  With Worksheets("E Nr")

    'Alle E-Nummern

    Set R = .Range("A2", .Range("A" & Rows.Count).End(xlUp))

    'Einlesen

    Data = R.Value

  End With

  'Daraus ein Dictonary erstellen für den schnellen Zugriff

  Set Dict = CreateObject("Scripting.Dictionary")

  Dict.CompareMode = vbTextCompare

  For i = 1 To UBound(Data)

    Key = Trim$(Data(i, 1))

    If Not Dict.Exists(Key) Then Dict.Add Key, 0

  Next

  With Worksheets("Artikelliste ")

    'Jede Zelle in Spalte D

    For Each R In Range("D2", Range("D" & Rows.Count).End(xlUp))

      'Einlesen

      Data = R.Value

      'Suche nach einem "E"

      i = InStr(1, Data, "E")

      'Gefunden?

      Do While i > 0

        'Die nächsten gültigen Zeichen scannen

        j = i + 1

        Key = Trim$("E" & ValidWhile(j, Data, " 0123456789"))

        'E-Nummer vorhanden?

        If Dict.Exists(Key) Then

          'Ja, einfärben

          R.Characters(i, Len(Key)).Font.Color = vbRed

        End If

Skip:

        'Nächstes "E" suchen

        i = InStr(j, Data, "E", vbTextCompare)

      Loop

    Next

  End With

End Sub

Private Function ValidWhile(ByRef Start As Long, ByVal s As String, ByVal Delims As String, _

    Optional ByVal Compare As VbCompareMethod = vbTextCompare) As String

  'Returns the substring of S from Start while a delimiter is found

  Dim i As Long

  If Start < 1 Then Exit Function

  For i = Start To Len(s)

    If InStr(1, Delims, Mid$(s, i, 1), Compare) = 0 Then Exit For

  Next

  ValidWhile = Mid$(s, Start, i - Start)

  Start = i

End Function

Hallo Andreas

Die Liste ist hier zu finden:

https://www.dropbox.com/s/ytnrzkp0vmt6ht8/Liste%20Produkte%20Inhaltsstoffe.xls?dl=0

Ziel ist es, dass alle Wörter, welche im Tab "E Nr" vorkommen, vorne in der Spalte D rot werden.

Danke für die Hilfe!

Grüsse

Michèle