Gibt es die Möglichkeit das mit einer Formatierung zu lösen ohne dass alle Wörter in eigene Zellen aufgeteilt werden müssen? Es ist wichtig das zumindest die aneinander gereihten Wörter in einer Zelle stehen. Eventuell mit der Such-Funktion? Ich muss dies für mehr als 2000 Produkte machen, darum wäre es sehr aufwendig das für alle Produkte einzeln zu machen.
Die Datei sieht nun folgendermaßen aus:
Farbige Markierung.xlsm (Größe: 16,11 KB / Downloads: 1)
Leider markiert er jetzt bloß soweit wie die Länge aus A1.Ich möchte jedoch, dass er explizit nach den Wörtern sucht. Gibt es die Möglichkeit, dass ein Wort mit Leerzeichen als ein "Suchwort" angesehen wird? Ich bin leider absoluter Anfänger was Makros angeht.
Allerdings gäbe es da ein Problem. Das würde das Wort am Anfang oder Ende nicht finden. Da würden zusätzlich zu der vorhandenen Suche noch diese Zeilen helfen:
if Suche = 0 then
'Suche am Anfang
Suche = InStr(1, Worksheets("Sheet2").Cells(1, 2) & " ", Worksheets("Sheet2").Cells(10, 1))
end if
if Suche = 0 then
'Suche am Ende
Suche = InStr(1, " " & Worksheets("Sheet2").Cells(1, 2), Worksheets("Sheet2").Cells(10, 1))
end if
Sollte es das Wort mehrmals geben, müsste man das auch in einer Schleife verarbeiten, ansonsten wird nur der erste Treffer gefärbt
Sollte das Wort am Anfang stehen und z.B. ein Satzzeichen folgen, würde es nicht gefunden, z.B. Suche nach "Morgens" in diesem Satz
Morgens, wenn die Sonne aufgeht ...
. \\\|/// Hoffe, geholfen zu haben. ( ô ô ) Grüße, André aus G in T ooO-(_)-Ooo (Excel 97-2019+365)
die Datenstruktur, insbesondere wenn Suchbegriffe Worteile sind ("in" und "Kinder") ist kompliziert.
Hier ein Vorschlag:
Code:
Sub F_en()
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
sw = Split(Cells(i, 1))
Tx = Replace(Cells(i, 2), Chr(10), Chr(32))
mx = Split(Tx)
For b = LBound(sw) To UBound(sw)
Debug.Assert sw(b) <> "in"
anz = Filter(mx, sw(b))
If UBound(anz) = -1 Then GoTo NN
rep = UBound(anz) + 1
st = 1
pp = 0
Do
rep = rep - 1
If Len(sw(b)) = Len(anz(pp)) Then
pos = InStr(st, Cells(i, 2), sw(b), vbTextCompare)
st = pos + 1
If pos > 0 Then
Debug.Print sw(b), pos, UBound(anz), rep
Cells(i, 3).Characters(pos, Len(sw(b))).Font.Color = vbRed
End If
Else: pp = pp + 1
End If
Loop Until rep <= 0
NN:
Next b
Next i
End Sub
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
sw = Split(Cells(i, 1))
Tx = Replace(Cells(i, 2), Chr(10), Chr(32))
mx = Split(Tx)
For b = LBound(sw) To UBound(sw)
For m = LBound(mx) To UBound(mx)
If sw(b) = mx(m) Then
Debug.Print mx(m)
p = 1
Do
pos = InStr(p, Cells(i, 2), mx(m), vbTextCompare)
Cells(i, 2).Characters(pos, Len(sw(b))).Font.Color = vbRed
p = pos + 1
Loop While pos > 0
Exit For
End If
Next m
Next b
Next i
End Sub