excel and fun?

[antonov]

hello everybody, I have 2 questions:

1. my worksheets contain a macro that shows, randomly, some sentences in the
status bar. I is possible to get the text to scroll allowing for longer
texts)

2. I have this sheet in which, by means of simple calculations, my collegues
and I can see if a target has been reached. I would love to be able to see
something funny happening if the target is met (like a big smile or
whatever) and also if the target is not met (an angry face).

Is it possible to do so... and if it is...how?

Thanks for all the support

 

[Ken Johnson]

1.You could try singing along to this if you know the tune. Movement
is not all that smooth or steady and depending on the speed of your
machine you might have to adjust the end value in the For Next loop...

For I = 1 To 3000
DoEvents
Next I

make the 3000 larger to slow the scrolling or smaller to speed up.

Public Sub ScrollStatus()
Dim strMsg As String
Dim strSubMsgs(1 To 13) As String
Dim strDisplayMsg As String
Dim OldStatusBar
Dim K As Long, I As Long
OldStatusBar = Application.StatusBar
strSubMsgs(1) = " "
strSubMsgs(2) = "When there's a shine on your shoes, "
strSubMsgs(3) = "there's a melody in your heart, "
strSubMsgs(4) = "with a singable happy feeling, "
strSubMsgs(5) = "a wonderful way to start. "
strSubMsgs(6) = "You'll find the world every day "
strSubMsgs(7) = "with a deedle dum dee di di, "
strSubMsgs(8) = "with a melody that is making "
strSubMsgs(9) = "the worrying world go by. "
strSubMsgs(10) = "When you walk down the street "
strSubMsgs(11) = "with a happy-go-lucky beat, "
strSubMsgs(12) = "you'll find a lot in what I'm repeating. "
strSubMsgs(13) = "what a wonderful way to start the day."
For I = 1 To 12
strMsg = strMsg & strSubMsgs(I)
Next I
For I = 2 To 3
strMsg = strMsg & strSubMsgs(I)
Next I
strMsg = strMsg & strSubMsgs(13)

Do While K <= Len(strMsg)
K = K + 1
strDisplayMsg = Mid(strMsg, K, 150)
Application.StatusBar = strDisplayMsg
For I = 1 To 3000
DoEvents
Next I
Loop
Application.StatusBar = OldStatusBar
End Sub

2. You could draw the SmileyFace AutoShape twice and adjust the mouth
to be happy on one and sad on the other. Select the happy one then
click in the Name Box on the left of the Formula Bar, type in Happy
then press Enter. Repeat for the Sad one but type in Sad. Position
them both near the the cell (A1 in my code) holding the value that is
hopefully going to achieve the Target value (100 in my code). If they
are identical size and shape and perfectly overlapping it will look
like the one face with a changing smile.

Then copy the following code, right click the sheet tab, choose "View
code" and paste it into the sheet code module. The code runs every
time the worksheet calculates. When A1 is greater than or equal to 100
the Happy face is visible while the Sad face is hidden, and vice versa
when A1 is less than the Target value of 100.

Private Sub Worksheet_Calculate()
Const TargetValue As Single = 100
If Range("A1").Value < TargetValue Then
Me.Shapes("Sad").Visible = True
Me.Shapes("Happy").Visible = False
Else: Me.Shapes("Sad").Visible = False
Me.Shapes("Happy").Visible = True
End If
End Sub

Ken Johnson

 

[Ken Johnson]

The code for Q2 can be simplified to...

Private Sub Worksheet_Calculate()
Const TargetValue As Single = 100
Me.Shapes("Sad").Visible = Range("A1").Value < TargetValue
Me.Shapes("Happy").Visible = Not Me.Shapes("Sad").Visible
End Sub

Ken Johnson

 

[antonov]

Hello Ken, I have tried both your answers but I get:

1. Compile error: Invalid outside procedure

2. There is no change in smiley when I change the value in the target cell.
Plus.. can the target cell have a calculation in it (i.e.
=IF(B29>0,IF(B29>=B31,"YES","NO"),"")

Thank you very much

 

[Ken Johnson]

Hi Lisa,

1. Compile error: Invalid outside procedure...

sounds like you have copied and pasted too much.

Make sure when you copy the code that you start at...

Public Sub ScrollStatus()

and finish at...

End Sub

If you copy anything above "Public Sub ScrollStatus()" or below "End
Sub" you will get the error message you mentioned.
I suspect you have copied and pasted...

For I = 1 To 3000
DoEvents
Next I

make the 3000 larger to slow the scrolling or smaller to speed up.


which appears above "Public Sub ScrollStatus()" and this has caused
the error. So just delete those lines and it should work.

2. There is no change in smiley when I change the value in the target cell.

Plus.. can the target cell have a calculation in it (i.e.
=IF(B29>0,IF(B29>=B31,"YES","NO"),"")


The code I supplied assumed the target value would be a number.
Looking at your formula I'm guessing you would want the Happy face to
appear when the formula returns "YES", Sad face to appear when the
formula returns "NO" and neither face when "" is the returned value.

If I'm correct then try...

Private Sub Worksheet_Calculate()
Dim rgTarget As Range
Set rgTarget = Range("A1")
'change A1 to suit your situation.
'Change A1 to the address of the cell
'with the formula...
'=IF(B29>0,IF(B29>=B31,"YES","NO"),"")
With rgTarget
Me.Shapes("Happy").Visible = .Value = "YES"
Me.Shapes("Sad").Visible = .Value = "NO"
End With
End Sub

Ken Johnson

 

[Ken Johnson]

Hi Lisa,

This one's even more fun. Add a SmileyFace AutoShape to your sheet,
make sure it is selected then click in the Name Box, on the left of
the Formula Bar, and type "MyFace" (without the speech marks) then
press Enter (don't forget to press Enter like I often do).
Copy the code below then right click the worksheet tab, select "View
Code" from the popup menu then paste in the code.

My code assumes the cell with the formula resulting in YES, NO or
blank is A1, so make sure you change the A1 in that part of the
code...

Set rgTarget = Range("A1")<<< change to suit your formula cell.

Now every time the worksheet calculates the code runs, and if the
return value of your formula changes then you should see the smile
smoothly move to a full smile when the formula cell changes to "YES",
a straight mouth when it changes to blank and an up-side-down smile
when it changes to "NO".
You can alter the speed of the smile change by changing the value of
the Speed constant...

Const Speed As Single = 5<<increase or decrease to make faster or
slower respectively.

On my old machine 5 took 2.8 seconds.

Private Sub Worksheet_Calculate()
'Increase or decrease the value of the
'constant Speed to increase or decrease
'the time MyFace takes to change its smile
Const Speed As Single = 5
Dim MyFace As Shape
Dim rgTarget As Range
Dim MOODi As Single
Dim MOODf As Single
Dim MOOD_ChgDrn As Long
Set MyFace = Me.Shapes("MyFace")
Set rgTarget = Range("A1")
'change A1 to suit your situation.
'Change A1 to the address of the cell
'with the formula...
'=IF(B29>0,IF(B29>=B31,"YES","NO"),"")
MOODi = MyFace.Adjustments.Item(1)
Select Case rgTarget.Value
Case "YES"
MOODf = 0.8111111
Case "NO"
MOODf = 0.7180555
Case Else
MOODf = 0.7645833
End Select
MOOD_ChgDrn = Sgn(Round(MOODf, 7) - Round(MOODi, 7))
Select Case MOOD_ChgDrn
Case 0
Exit Sub
Case 1
Do Until MOODi >= MOODf
MOODi = MOODi + Speed / 10000
MyFace.Adjustments.Item(1) = MOODi
DoEvents
Loop

Case -1
Do Until MOODi <= MOODf
MOODi = MOODi - Speed / 10000
MyFace.Adjustments.Item(1) = MOODi
DoEvents
Loop
End Select
End Sub

Have Fun!

Ken Johnson

 

[Lisa]

Hi there Ken, sorry for the late reply but I've had some personal matters to
attend to. A friend of mine died and I didn't feel like being behind my pc.
Today I've tried your suggestions. The scrolling text works fine, but.. I
would like to show you the code I am using now and ask you if it is possible
to mix your code together with mine and get longer texts to scroll.

The smiling and sad faces do not work. I am pretty sure I am doing something
wrong but I cannot figure out what... I will try them again and let you know
all the steps I take and what I do exactely...

All the above only if it is alright with you

Thanks for you patience and help

 

[Ken Johnson]

Hi Lisa,

With sad news like that you really need a smiley face.

I'll do what ever is needed to get both working the way you want,
assuming my Excel skills are up to the task.

If it's possible to send me a copy (or something similar) of the
workbook(s) then please do. It's always easier working with actual
workbooks than using one's imagination.
You know how to get my email address from "View Profile"?

Ken Johnson