Hello Bernie,

this works good for me.
A big plus is that the undo (Ctrl+Z) function works again when I select more
than one cell.

Thanks a lot.

Kind regards from Pierre

"Bernie Deitrick" wrote:

Pierre,

You could check for the number of cells first:

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim X As Long
Dim R As Range

If Target.Cells.Count 1 Then Exit Sub

If you never use Ctrl-Enter to change multiple cells at once, then leaving
the comparison at 1 is OK.

HTH,
Bernie
MS Excel MVP


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

I still have problems with the code you gave me.
Not the macro but the other one.
I made a new workbook with one worksheet.
I have put the non-macro in the ThisWorkbook sheet.
I deleted several comluns at one time and then Excel is working over and
over.
When I hit the Esc key I select the "debug/error" button (I work with a
duch
version) this line is colored yellow:

For X = 1 To Len(R.Value)

so I suppose there is the reason why it takes so long.
I hope you have the same and will be able to fix it.
If you don't have it, do you have any idea what the problem could be?

Pierre

This is the code I use:

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
R.Characters.Font.ColorIndex = xlColorIndexAutomatic
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 = 23
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 = 45
End Select
If X 1 Then 'SA text
If Mid(R.Value, X - 1, 2) = "SA" Then
R.Characters(X - 1, 2).Font.ColorIndex = 7
End If
End If
Next
Next
End Sub