Hi again,

Am Fri, 11 Oct 2013 13:37:26 -0400 schrieb wabbleknee:

working with it now.

here it is now with arrBlue. You only have to fill all your numbers to
the arrays:

Sub Color()
Dim arrGreen As Variant
Dim arrRed As Variant
Dim arrBlue As Variant
Dim rngC As Range
Dim LRow As Long
Dim i As Integer
Dim n As Integer
Dim intStart As Integer
Dim intLen As Integer

arrGreen = Array(789, 790, 791, 212)
arrRed = Array(123, 222, 541, 346, 718)
arrBlue = Array(999)
LRow = Cells(Rows.Count, 4).End(xlUp).Row
For Each rngC In Range("D1:D" & LRow)
For i = LBound(arrGreen) To UBound(arrGreen)
For n = 1 To Len(rngC)
intStart = InStr(n, rngC, arrGreen(i) & ".")
If intStart 0 Then
intLen = InStr(intStart, rngC, ",") - intStart
rngC.Characters(intStart, intLen).Font.Color = vbGreen
n = n + intStart + intLen
Else
Exit For
End If
Next
Next
For i = LBound(arrRed) To UBound(arrRed)
For n = 1 To Len(rngC)
intStart = InStr(n, rngC, arrRed(i) & ".")
If intStart 0 Then
intLen = InStr(intStart, rngC, ",") - intStart
rngC.Characters(intStart, intLen).Font.Color = vbRed
n = n + intStart + intLen
Else
Exit For
End If
Next
Next
For i = LBound(arrBlue) To UBound(arrBlue)
For n = 1 To Len(rngC)
intStart = InStr(n, rngC, arrBlue(i) & ".")
If intStart 0 Then
intLen = InStr(intStart, rngC, ",") - intStart
rngC.Characters(intStart, intLen).Font.Color = vbBlue
n = n + intStart + intLen
Else
Exit For
End If
Next
Next
Next
End Sub


Regards
Claus B.
--
Win XP PRof SP2 / Vista Ultimate SP2
Office 2003 SP2 /2007 Ultimate SP2