Conditional formatting ♣ ♦ ♥ ♠ NT

P

Pierre62

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
 
P

Pierre62

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
 
G

Gary''s Student

Hi Pierre62:

Getting symbols into VBA can be tedious. Lets use some cells to help us.
In Z1 thru Z4 we first enter:

♣
♦
♥
â™ 


and then an update to your poste code:

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 Integer, j As Integer, v As Variant, L As Integer


strToFind = Range("Z4").Value
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
v = foundCell.Value
L = Len(v)
For i = 1 To L
startPos = InStr(i, v, strToFind)
If startPos > 0 Then
With foundCell.Characters(Start:=startPos, _
Length:=lngTofind).Font
.Color = vbBlue
'.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


Should give you blue â™ 
 
R

Rick Rothstein

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)?
 
P

Pierre62

Hello Garrys'student.

I indeed get blue spades.
So the next step would be to get the other symbols also in the right color.
And is it possible to make the script work for aal worksheets in my workbook
with over 50 worksheet.

Thanks for your help
Pierre
 
P

Pierre62

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
 
B

Bernie Deitrick

Pierre,

The code FormatAllSheetsText (below) will work on all sheets.

To get it to work, on Sheet1, in cells Z1:Z4, enter

club in Z1
diamond in Z2
heart in Z3
spade in Z4

And the code below that (FormatOneCellsText) can be used as you enter new
values, with the workbook's sheet change event:

Paste this code into the codemodule of the ThisWorkbook object:

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
FormatOneCellsText Target
End Sub



HTH,
Bernie
MS Excel MVP

Sub FormatAllSheetsText()
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 Integer
Dim j As Integer
Dim v As Variant
Dim L As Integer
Dim myC As Range
Dim mySht As Worksheet
Dim myColors As Variant
Dim myColor As Variant


myColors = Array(50, 46, 3, 41)


For Each myC In Worksheets("Sheet1").Range("Z1:Z4")
strToFind = myC.Value
myColor = myColors(myC.Row - 1)
lngTofind = Len(strToFind)

For Each mySht In Worksheets
With mySht '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
v = foundCell.Value
L = Len(v)
For i = 1 To L
startPos = InStr(i, v, strToFind)
If startPos > 0 Then
With foundCell.Characters(Start:=startPos, _
Length:=lngTofind).Font
.ColorIndex = myColor
'.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
Next mySht
Next myC
End Sub

Sub FormatOneCellsText(myTarget As Range)
Dim strToFind As String
Dim lngTofind As Long
Dim startPos As Long
Dim myC As Range
Dim i As Integer
Dim j As Integer
Dim v As Variant
Dim L As Integer
Dim myColors As Variant
Dim myColor As Variant
' green clubs - club in Z1
' orange diamonds - in Z2
' red hearts - in Z3
' blue spades - in Z4

myColors = Array(50, 46, 3, 41)
For Each myC In Worksheets("Sheet1").Range("Z1:Z4")
strToFind = myC.Value
myColor = myColors(myC.Row - 1)
lngTofind = Len(strToFind)
With myTarget
v = .Value
L = Len(v)
For i = 1 To L
startPos = InStr(i, v, strToFind)
If startPos > 0 Then
With .Characters(Start:=startPos, _
Length:=lngTofind).Font
.ColorIndex = myColor
'.Bold = True 'Other formatting if required
End With
End If
Next i
End With
Next myC
End Sub
 
R

Rick Rothstein

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.
 
R

Rick Rothstein

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
 
R

Rick Rothstein

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.
 
K

keiji kounoike

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
 
R

Rick Rothstein

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.
 
R

Rick Rothstein

Stealing an idea from Keiji (sorry Keiji<g>), this coding should be slightly
more efficient than what I posted earlier...

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 = 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
End Select
If X > 1 Then 'NT text
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
 
R

Rick Rothstein

Stealing an idea from Keiji (sorry Keiji<g>), this coding should be slightly
more efficient than what I posted earlier...

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
R.Characters.Font.ColorIndex = xlColorIndexAutomatic
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
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
 
P

Pierre62

Hello Rick, Keiji Gary's student and Bernie,

I don't know what went wrong but after saving may spreadsheet and reopening
it again the next day all my sheets were blank.
Fortunally I have a backup of a month ago so I did not loose toot much work.

I had to allow all macros. Is it possible to digitally sign the work you did
for me?

Grand Slam for you guys.
I am so happy.

Pierre
 
R

Rick Rothstein

I'm not sure what you mean by "digitally sign the work"... just copy/paste
them into your workbook where indicated and they are yours to use.
 
P

Pierre62

At the moment I have to accept all macros utherwise yours will not work.
I think this is not very safe.
There is an option to block all macros except the ones which are digitally
signed.
I made a certificate with selcert.exe but it still does not work.

Pierre
 
R

Rick Rothstein

I've never worked with digital signatures, so I'm not sure what I can do to
help you out there. I think there is a way that you can digitally self-sign
your macros (which would mean you could copy/paste the code into your own
work and then digitally sign that). Perhaps someone familiar with the
process will come along and follow up on this for you. You could consider
lowering your security setting and visually analyze/examine any macros
before you implement them in your own workbooks (the setting you are
currently using would be most effective if you take in workbooks from other
sources and try to run them on your own system... I wouldn't think code you
create or implement should not require such a high setting. Also, trying
them out on a copy of your workbook so they can't accidentally affect any of
your original data is something you might also consider.
 
G

Gord Dibben

For Pierre

Set your macro security settings to "Disable with notification" and you will
get the option to enable or disable macros when you open the workbook.

If you don't want to deal with the warning you can sign the workbook with
the selefcert DS you created.

If you have already created a selfcert DS you will find it the Management
Console under Personal Signatures after loading the Signatures Snap-in.

Steps............after closing Excel

Start>Run mmc

Load the MMC digital signature snap-in from File>Add/Remove Snap-in

Select Certificates and Certificates-Current User

Open Personal folder.

You must copy the selfcert DS from Personal Signatures to Trusted Publishers

Then...............................

With your workbook open and in VBE, select Tools>Digital Signatures>Choose

Your selfcert DS will be available for signing that workbook.


Gord Dibben MS Excel MVP
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

.FindNext problem 3
Search and Replace a Spacific Character with Conditional Formating 17
Method ‘CurrentPage’ of object ‘Pivot ‘Failed “ 0
Set ws = ActiveSheet Compile error Can't find project or Library 8
VBA Help 0
Match several values in ‘Summary Sheet’ to several values in ‘Mast 4
Copy numbers from an array, each to it’s own sheet 4
MACRO Effeciency 3

Top