Just so you are aware... the code in both of my posting are completely stand
alone and do NOT require any helper cells in order to work.

--
Rick (MVP - Excel)


"Rick Rothstein" wrote in message
...
By the way, if you did not want to do it the automatic way I outlined in
my previous posting, then here is the code re-worked into a macro that
will process all the text in all your worksheets at one time when you
execute it...

Sub ColorSuitSymbols()
Dim X As Long
Dim R As Range
Dim W As Worksheet
On Error Resume Next
For Each W In Worksheets
For Each R In W.UsedRange
For X = 1 To Len(R.Value)
Select Case AscW(Mid(R.Value, X, 1))
Case 9824
R.Characters(X, 1).Font.ColorIndex = 5
Case 9827
R.Characters(X, 1).Font.ColorIndex = 10
Case 9829
R.Characters(X, 1).Font.ColorIndex = 3
Case 9830
R.Characters(X, 1).Font.ColorIndex = 46
Case Else
R.Characters(X, 1).Font.ColorIndex = xlColorIndexAutomatic
End Select
If X 1 Then
If Mid(R.Value, X - 1, 2) = "NT" Then
R.Characters(X - 1, 2).Font.ColorIndex = 44
End If
End If
Next
Next
Next
End Sub

--
Rick (MVP - Excel)


"Rick Rothstein" wrote in message
...
Okay, here is a method to automatically color your symbols when you make
the entry into a cell. To implement this solution, right-click the XL
symbol immediately to the left of the File menu item and copy/paste the
following code into the code window that appears...

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As
Range)
Dim X As Long
Dim R As Range
For Each R In Target
For X = 1 To Len(R.Value)
Select Case AscW(Mid(R.Value, X, 1))
Case 9824 'Spade symbol
R.Characters(X, 1).Font.ColorIndex = 5
Case 9827 'Club symbol
R.Characters(X, 1).Font.ColorIndex = 10
Case 9829 'Heart symbol
R.Characters(X, 1).Font.ColorIndex = 3
Case 9830 'Diamond symbol
R.Characters(X, 1).Font.ColorIndex = 46
Case Else 'No Trump symbol
R.Characters(X, 1).Font.ColorIndex = xlColorIndexAutomatic
End Select
If X 1 Then
If Mid(R.Value, X - 1, 2) = "NT" Then
R.Characters(X - 1, 2).Font.ColorIndex = 44
End If
End If
Next
Next
End Sub

Now, go back any worksheet and type some text that contains your card
symbols and/or No Trump symbol (note... you can have more than one symbol
within your text string if you want or need to)... when you hit the Enter
Key, those symbols will change color. Oh, and you can change the
ColorIndex assignments from those that I used if you want to... I added
some remark comments in the various Case statements so you will know
which symbol you are dealing with.

--
Rick (MVP - Excel)


"Pierre62" wrote in message
...
Hello Rick,

I use the Arial narrow font.

™£ = left Alt key + 5 of the numeric keypad
™¦ = left Alt key + 4 of the numeric keypad
™¥ = left Alt key + 3 of the numeric keypad
™* = left Alt key + 6 of the numeric keypad

I think this is in most fonts the same.

Thanks in advance for spending time to my problem.
Kind regards, Pierre

"Rick Rothstein" wrote:

How are you getting the ™£ ™¦ ™¥ ™* and NT "shapes" into your cells? Are
they
text characters from a font (if so, which one) or something else (if
so,
what)?

--
Rick (MVP - Excel)


"Pierre62" wrote in message
...
Hello all, OssieMac,

I use excel to work out my conventions in the noble Bridge game.
Often I use things like 2™¦.
I like to change the colour of the ™¦ symbol into orange.
I do it by hand and it takes a lot of time.
I saw the question of Kay and the code of OssieMac is just what I
need.

Who can help me to change the code to work with the symbols I use in
the
colours I like?

™£ green
™¦ orange
™¥ red
™* blue
NT yellow


In advance, I thank you very much.
Pierre


Ossiemac gave the following code:

Do I interpret your comment to mean that " eg" can appear more than
once
in
the cells? If so, then the following will fix it although you
probably do
not
need it now if Gary's macro did the job.


Sub Format_Text()
Dim strToFind As String
Dim lngTofind As Long
Dim rngUsed As Range
Dim foundCell As Range
Dim startPos As Long
Dim firstAddress As String
Dim i As Long

strToFind = " eg" 'Set to required string

lngTofind = Len(strToFind)

With Sheets("Sheet1") 'Edit for your sheet name
Set rngUsed = .UsedRange
End With

With rngUsed
Set foundCell = .Find(What:=strToFind, _
LookIn:=xlFormulas, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)

If Not foundCell Is Nothing Then
firstAddress = foundCell.Address

Do
For i = 1 To Len(foundCell)
startPos = InStr(i, foundCell, strToFind)
If startPos 0 Then
With foundCell.Characters(Start:=startPos, _
Length:=lngTofind).Font
.Color = vbRed
'.Bold = True 'Other formatting if required
End With
End If
Next i
Set foundCell = .FindNext(foundCell)
Loop While Not foundCell Is Nothing And _
foundCell.Address < firstAddress
End If
End With
End Sub