conditional formating problem

[spudgun44]

I want to enter a letter into a cell (based on traffic lights R,A,G)

but then I want that cell to display a smiley (green - happy, amber - straight mouth, and red unhappy)

in addition to this I would like the smileys to be the same colour as the letter entred

is this possible? I have tried it but keep coming accross circular formula errors

Thanks

 

[Upex]

Hi Spudgun44

Do you want this to be via VBA or just via the conditional formatting within the cell?

 

[spudgun44]

Which ever would be the easiest, I and just leaning and doing things with VBA so it would be useful to see both ways

 

[Upex]

What version of XL are you using?

I know 2003 and above have coloured icons that you can apply due to cell value, i.e. traffic lights, but I don't think they have smilies. Do they have to be smilies?

A starting point may be an event change macro that would replace the target cell value with whatever you chose, ie for R values, change colour to red and insert etc.

I'll have a look and see what I can throw together, but I'm sure there are better ways that a Guru on here will know, as I to am just starting on the road to Excel/VBA discovery.

Upex.

 

[spudgun44]

I am using 2002 excel and this is a work project and they are still on 97!!!

I would prefer it if it was a smily such as the ones on webdings/windings

 

[Upex]

Something like this may work. Not ideal though as case statements aren't great.

Option Compare Text
Option Explicit
 
Private Sub Worksheet_Change(ByVal Target As Range)
 
    Dim Cell As Range
    Dim Rng1 As Range
 
    On Error Resume Next
    Set Rng1 = Target
    On Error GoTo 0
    If Rng1 Is Nothing Then
        Set Rng1 = Target
    Else
        Set Rng1 = Union(Range(Target.Address), Rng1)
    End If
    For Each Cell In Rng1
        Select Case Cell.Value
            Case "R"
                Cell.Value = ":-)"
                Cell.Font.ColorIndex = 3
 
            Case "A"
                Cell.Value = ":-I)"
                Cell.Font.ColorIndex = 46
 
            Case "G"
                Cell.Value = ":-("
                Cell.Font.ColorIndex = 4
 
            Case Else
               
        End Select
    Next
 
End Sub

Would need to go into the worksheet code. Interms of getting the actual smilie picture, I've never worked with them, but think that you would probably need an add on and work with that to get it to do the smilies, but I may be wrong. If not, I would also say that your end result will suffer if people run the code without the addon being installed.

I did try to insert smilie shape in a cell and then call that as the value, but didn't work.

Sorry couldnt offer a solution. Hope you get it sorted. If so, post back here so we can have a look.

Upex

 

[Upex]

Try this instead: Will give you a Red, Amber or Green smilie in each cell where you put a R, A or G:

Option Compare Text
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
     
    Dim Cell As Range
    Dim Rng1 As Range
     
    On Error Resume Next
    Set Rng1 = Target
    On Error GoTo 0
    If Rng1 Is Nothing Then
        Set Rng1 = Target
    Else
        Set Rng1 = Union(Range(Target.Address), Rng1)
    End If
    For Each Cell In Rng1
        Select Case Cell.Value
            Case "R"
                Cell.Value = "L"
                    With Cell.Font
                    .ColorIndex = 3
                    .Name = "Wingdings"
                    .Bold = True
                    .Size = 26
                    End With
            Case "A"
                Cell.Value = "K"
                    With Cell.Font
                    .ColorIndex = 46
                    .Name = "Wingdings"
                    .Bold = True
                    .Size = 26
                    End With
            Case "G"
                Cell.Value = "J"
                    With Cell.Font
                    .ColorIndex = 4
                    .Name = "Wingdings"
                    .Bold = True
                    .Size = 26
                    End With
            Case Else
                 With Cell.Font
                 .ColorIndex = xlAutomatic
                 .Bold = False
                 .Size = 11
                 End With
        End Select
    Next
End Sub

Obviously you can adjust the font settings (size, colour etc) - just dont change the font for the RAG cases.

Hope this is more what your looking for.

Upex

 

[spudgun44]

thanks, this is great,

how to I set it to either a specific range or a specific column??

 

[Upex]

Give this a go (untested):

Option Compare Text
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
    
    If Target.Count > 1 Then Exit Sub  ' will stop the code from running if more than one cell within the range is changed at once you may want to change this? or remove al together depending on your set up.
    If Not Application.Intersect(Target, Range("D2:D100")) Is Nothing Then ' Change D2:D100 to the range that you want the smilies to apply to. can be a column as D:D.
        
        Dim Cell As Range
        Dim Rng1 As Range
        
        On Error Resume Next
        Set Rng1 = Target
        On Error GoTo 0
        If Rng1 Is Nothing Then
            Set Rng1 = Target
        Else
            Set Rng1 = Union(Range(Target.Address), Rng1)
        End If
        
        For Each Cell In Rng1
            Select Case Cell.Value
                Case "R"
                    Cell.Value = "L"
                        With Cell.Font
                        .ColorIndex = 3
                        .Name = "Wingdings"
                        .Bold = True
                        .Size = 26
                        End With
                Case "A"
                    Cell.Value = "K"
                        With Cell.Font
                        .ColorIndex = 46
                        .Name = "Wingdings"
                        .Bold = True
                        .Size = 26
                        End With
                Case "G"
                    Cell.Value = "J"
                        With Cell.Font
                        .ColorIndex = 4
                        .Name = "Wingdings"
                        .Bold = True
                        .Size = 26
                        End With
                Case Else
                     With Cell.Font
                     .ColorIndex = xlAutomatic
                     .Bold = False
                     .Size = 11
                     End With
            End Select
        Next
        Else
    End If
End Sub

Hope this works for you :-S

Upex

 

[spudgun44]

thanks, this works like a dream