This one is written by with reference to Rick's code without permission
of Rick. sorry, Rick.
Copy the following code into ThisWorkbook Module.

Private Sub Workbook_SheetChange _
(ByVal Sh As Object, ByVal Target As Range)
Dim i As Long

Application.EnableEvents = False
On Error Resume Next
Target.Font.colorindex = xlColorIndexAutomatic
i = 1
With Target
Do While (i <= Len(.Value))
If AscW(Mid(.Value, i, 1)) = 9824 Then
.Characters(i, 1).Font.colorindex = 5
i = i + 1
ElseIf AscW(Mid(.Value, i, 1)) = 9827 Then
.Characters(i, 1).Font.colorindex = 10
i = i + 1
ElseIf AscW(Mid(.Value, i, 1)) = 9829 Then
.Characters(i, 1).Font.colorindex = 3
i = i + 1
ElseIf AscW(Mid(.Value, i, 1)) = 9830 Then
.Characters(i, 1).Font.colorindex = 46
i = i + 1
ElseIf UCase(Mid(.Value, i, 2)) = "NT" Then
.Characters(i, 2).Font.colorindex = 44
i = i + 2
Else
i = i + 1
End If
Loop
End With
Application.EnableEvents = True
End Sub

Keiji

Pierre62 wrote:
Sorry for asking for more....

Is it possible to make the formula work in all sheets I have in one file or
do I have to put the code in all separat sheets?
Does the code work with Office 1997?

Kind regards.
Pierre

I never have a problem with someone using code I posted... it is kind of why
I post it in the first place.<g

Just a couple of comments. First, you do not need to turn off EnableEvents
during your procedure... changing the color of the parts of a cell or its
contents does not evoke a Change event. Second, I wouldn't UCase the text
when searching for "NT" as that would color the "nt" in a word that might be
on the page (such as the last 2 letters of "Bridge Tournament")... the NT
(abbreviation for No Trump) will always be in upper case. Third, just for
style, I would move all the i=i+1 statements you have inside of the If..Then
blocks to a single location in front of the If..Then statement, then delete
the i=1 and then simply change the i=i+2 statement in the "NT" block of code
to i=i+1. This is how I would have written your code...

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim i As Long
On Error Resume Next
Target.Font.ColorIndex = xlColorIndexAutomatic
With Target
Do While (i <= Len(.Value))
i = i + 1
If AscW(Mid(.Value, i, 1)) = 9824 Then
.Characters(i, 1).Font.ColorIndex = 5
ElseIf AscW(Mid(.Value, i, 1)) = 9827 Then
.Characters(i, 1).Font.ColorIndex = 10
ElseIf AscW(Mid(.Value, i, 1)) = 9829 Then
.Characters(i, 1).Font.ColorIndex = 3
ElseIf AscW(Mid(.Value, i, 1)) = 9830 Then
.Characters(i, 1).Font.ColorIndex = 46
ElseIf Mid(.Value, i, 2) = "NT" Then
.Characters(i, 2).Font.ColorIndex = 44
i = i + 1
End If
Loop
End With
End Sub

By the way, I do like your treatment for applying the xlColorIndexAutomatic
condition to the font characters all at once and then just coloring the
one's that need to be changed.

--
Rick (MVP - Excel)


"keiji kounoike" <"kounoike AT mbh.nifty.com" wrote in message
...
This one is written by with reference to Rick's code without permission of
Rick. sorry, Rick.
Copy the following code into ThisWorkbook Module.

Private Sub Workbook_SheetChange _
(ByVal Sh As Object, ByVal Target As Range)
Dim i As Long

Application.EnableEvents = False
On Error Resume Next
Target.Font.colorindex = xlColorIndexAutomatic
i = 1
With Target
Do While (i <= Len(.Value))
If AscW(Mid(.Value, i, 1)) = 9824 Then
.Characters(i, 1).Font.colorindex = 5
i = i + 1
ElseIf AscW(Mid(.Value, i, 1)) = 9827 Then
.Characters(i, 1).Font.colorindex = 10
i = i + 1
ElseIf AscW(Mid(.Value, i, 1)) = 9829 Then
.Characters(i, 1).Font.colorindex = 3
i = i + 1
ElseIf AscW(Mid(.Value, i, 1)) = 9830 Then
.Characters(i, 1).Font.colorindex = 46
i = i + 1
ElseIf UCase(Mid(.Value, i, 2)) = "NT" Then
.Characters(i, 2).Font.colorindex = 44
i = i + 2
Else
i = i + 1
End If
Loop
End With
Application.EnableEvents = True
End Sub

Keiji

Pierre62 wrote:
Sorry for asking for more....

Is it possible to make the formula work in all sheets I have in one file
or do I have to put the code in all separat sheets?
Does the code work with Office 1997?

Kind regards.
Pierre

Hi Rick

Thank you for your nice comments. I know no need of EnableEvents in this
case, but i put it for the future's change though it would not happen. I
like your style of moving i=i+1 out of if block and it has made my code
very simple. Changing the color at first place contributes to the
speeding up the time of process in my test. Anyway, thanks again.

Keiji

Rick Rothstein wrote:
I never have a problem with someone using code I posted... it is kind of
why I post it in the first place.<g

Just a couple of comments. First, you do not need to turn off
EnableEvents during your procedure... changing the color of the parts of
a cell or its contents does not evoke a Change event. Second, I wouldn't
UCase the text when searching for "NT" as that would color the "nt" in a
word that might be on the page (such as the last 2 letters of "Bridge
Tournament")... the NT (abbreviation for No Trump) will always be in
upper case. Third, just for style, I would move all the i=i+1 statements
you have inside of the If..Then blocks to a single location in front of
the If..Then statement, then delete the i=1 and then simply change the
i=i+2 statement in the "NT" block of code to i=i+1. This is how I would
have written your code...

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim i As Long
On Error Resume Next
Target.Font.ColorIndex = xlColorIndexAutomatic
With Target
Do While (i <= Len(.Value))
i = i + 1
If AscW(Mid(.Value, i, 1)) = 9824 Then
.Characters(i, 1).Font.ColorIndex = 5
ElseIf AscW(Mid(.Value, i, 1)) = 9827 Then
.Characters(i, 1).Font.ColorIndex = 10
ElseIf AscW(Mid(.Value, i, 1)) = 9829 Then
.Characters(i, 1).Font.ColorIndex = 3
ElseIf AscW(Mid(.Value, i, 1)) = 9830 Then
.Characters(i, 1).Font.ColorIndex = 46
ElseIf Mid(.Value, i, 2) = "NT" Then
.Characters(i, 2).Font.ColorIndex = 44
i = i + 1
End If
Loop
End With
End Sub

By the way, I do like your treatment for applying the
xlColorIndexAutomatic condition to the font characters all at once and
then just coloring the one's that need to be changed.