Extending existing coding to include new parameters

C

Colin Hayes

Hi All

I need some help to extend some existing VBA.

To indicate when the content on the sheet was last updated. I use this
code :

..Range("A21").Value = "Last Updated : " & Format(Now, " dddd dd/mm/yy
at hh:mm:ss")


It reads , for example :

Last Updated : Thursday 30/06/11 at 19:45:27


I need to extend it to include reference to shop opening and closing
times.

The shop is open between 8 am and 4.30 pm , and closed outside these
hours.

So the output of the new code would read something like :

Last Updated : Thursday 30/06/11 at 19:45:27 , when the shop was
closed.

Or

Last Updated : Thursday 30/06/11 at 11:45:27 , when the shop was
open.


Can someone help to extend the coding?


Grateful for any advice.
 
G

GS

Try...

.Range("A21").Value = "Last Updated: " _
& Format(Now, " dddd dd/mm/yy at hh:mm:ss") _
& ", when the shop was " & Get_ShopOpenStatus(TimeValue(Now))


Function Get_ShopOpenStatus(CurrentTime As Variant) As String
Dim vShopOpens, vShopCloses
vShopOpens = TimeValue("8:00 AM")
vShopCloses = TimeValue("4:30 PM")
If TimeValue(Now) > vShopOpens And TimeValue(Now) < vShopCloses Then
_
Get_ShopOpenStatus = "open." Else Get_ShopOpenStatus = "closed."
End Function
 
G

GS

Sorry Colin, I forgot to copy/paste the revised function!

Function Get_ShopOpenStatus(CurrentTime As Variant) As String
Dim vShopOpens, vShopCloses
vShopOpens = TimeValue("8:00 AM")
vShopCloses = TimeValue("4:30 PM")
If CurrentTime > vShopOpens And CurrentTime < vShopCloses Then _
Get_ShopOpenStatus = "open." Else Get_ShopOpenStatus = "closed."
End Function
 
C

Colin Hayes

Try...

.Range("A21").Value = "Last Updated: " _
& Format(Now, " dddd dd/mm/yy at hh:mm:ss") _
& ", when the shop was " & Get_ShopOpenStatus(TimeValue(Now))


Function Get_ShopOpenStatus(CurrentTime As Variant) As String
Dim vShopOpens, vShopCloses
vShopOpens = TimeValue("8:00 AM")
vShopCloses = TimeValue("4:30 PM")
If TimeValue(Now) > vShopOpens And TimeValue(Now) < vShopCloses Then
_
Get_ShopOpenStatus = "open." Else Get_ShopOpenStatus = "closed."
End Function
Click to expand...


HI Garry

OK thanks for getting but so expertly.

I'm getting an 'Expected End Sub' error just before the line

Function Get_ShopOpenStatus(CurrentTime As Variant) As String

I'm placing your code in a Private Sub context under the tab on the
sheet. I wonder if this is causing the issue.

Thanks again for your help.
 
C

Colin Hayes

Sorry Colin, I forgot to copy/paste the revised function!

Function Get_ShopOpenStatus(CurrentTime As Variant) As String
Dim vShopOpens, vShopCloses
vShopOpens = TimeValue("8:00 AM")
vShopCloses = TimeValue("4:30 PM")
If CurrentTime > vShopOpens And CurrentTime < vShopCloses Then _
Get_ShopOpenStatus = "open." Else Get_ShopOpenStatus = "closed."
End Function
Click to expand...

Hi Garry

Sorry - here's the whole of the code I'm trying to fit yours into ;


Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo stoppit
Application.EnableEvents = False
If Me.Range("D4").Value <> "" Then
With Sheets("ShareSheet")
.Unprotect Password:="password"
.Range("A21").Value = "Last Updated : " & Format(Now, " dddd
dd/mm/yy at hh:mm:ss")
stoppit:
Application.EnableEvents = True
.Protect Password:="password"
End With
End If
End Sub


I should have sent it before. It will make the picture clearer.

Best Wishes
 
G

GS

Colin Hayes explained on 6/30/2011 :
HI Garry

OK thanks for getting but so expertly.

I'm getting an 'Expected End Sub' error just before the line

Function Get_ShopOpenStatus(CurrentTime As Variant) As String

I'm placing your code in a Private Sub context under the tab on the sheet. I
wonder if this is causing the issue.

Thanks again for your help.
Click to expand...

Colin,
The line of code is a revised version of the snippet of code you
provided in your original post. Just replace your original line with
mine...!
 
G

GS

Colin Hayes has brought this to us :
Hi Garry

Sorry - here's the whole of the code I'm trying to fit yours into ;


Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo stoppit
Application.EnableEvents = False
If Me.Range("D4").Value <> "" Then
With Sheets("ShareSheet")
.Unprotect Password:="password"
Click to expand...

Replace the following line with my revised version...
=======================================
.Range("A21").Value = "Last Updated : " & Format(Now, " dddd
dd/mm/yy at hh:mm:ss")
=======================================
 
C

Colin Hayes

Hi Garry

Yes , that's what I'm doing , in precisely the way you indicate , but
I'm still getting this 'Expected End Sub' error. Just before the start
of the Function code. Very mysterious. I'll give it another go.

This is the code I'm using now , with your revision in place. Does it
look OK to you?


Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo stoppit
Application.EnableEvents = False
If Me.Range("D4").Value <> "" Then
With Sheets("ShareSheet")
.Unprotect Password:="password"

.Range("A21").Value = "Last Updated: " _
& Format(Now, " dddd dd/mm/yy at hh:mm:ss") _
& ", when the shop was " & Get_ShopOpenStatus(TimeValue(Now))

Function Get_ShopOpenStatus(CurrentTime As Variant) As String
Dim vShopOpens, vShopCloses
vShopOpens = TimeValue("8:00 AM")
vShopCloses = TimeValue("4:30 PM")
If TimeValue(Now) > vShopOpens And TimeValue(Now) < vShopCloses Then _
Get_ShopOpenStatus = "open." Else Get_ShopOpenStatus = "closed."
End Function

stoppit:
Application.EnableEvents = True
.Protect Password:="password"
End With
End If
End Function


Thanks again Garry
 
G

GS

The function is a separate procedure, and so does not go inside your
Change event. Put it in a standard module. Let me know how you make
out...
 
G

GS

Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo stoppit
Application.EnableEvents = False
If Me.Range("D4").Value <> "" Then
With Sheets("ShareSheet")
.Unprotect Password:="password"
.Range("A21").Value = "Last Updated: " _
& Format(Now, " dddd dd/mm/yy at hh:mm:ss") _
& ", when the shop was " & Get_ShopOpenStatus(TimeValue(Now))

stoppit:
.Protect Password:="password"
End With
End If
Application.EnableEvents = True
End Sub

In a standard module...

Function Get_ShopOpenStatus(CurrentTime As Variant) As String
Dim vShopOpens, vShopCloses
vShopOpens = TimeValue("8:00 AM")
vShopCloses = TimeValue("4:30 PM")
If TimeValue(Now) > vShopOpens And TimeValue(Now) < vShopCloses Then
_
Get_ShopOpenStatus = "open." Else Get_ShopOpenStatus = "closed."
End Function
 
G

GS

Geez.., did it again! Revise function in previous reply to...

Function Get_ShopOpenStatus(CurrentTime As Variant) As String
Dim vShopOpens, vShopCloses
vShopOpens = TimeValue("8:00 AM")
vShopCloses = TimeValue("4:30 PM")
If CurrentTime > vShopOpens And CurrentTime < vShopCloses Then _
Get_ShopOpenStatus = "open." Else Get_ShopOpenStatus = "closed."
End Function
 
C

Colin Hayes

Geez.., did it again! Revise function in previous reply to...

Function Get_ShopOpenStatus(CurrentTime As Variant) As String
Dim vShopOpens, vShopCloses
vShopOpens = TimeValue("8:00 AM")
vShopCloses = TimeValue("4:30 PM")
If CurrentTime > vShopOpens And CurrentTime < vShopCloses Then _
Get_ShopOpenStatus = "open." Else Get_ShopOpenStatus = "closed."
End Function
Click to expand...


Hi Garry

OK that's fixed it. Working perfectly.

Thanks again for your time and considerable expertise.



Best Wishes


Colin
 
G

GS

You're very welcome! Glad you were able to sort it out. Next time..,
I'll be less presumptuous!<g>
 
C

Colin Hayes

You're very welcome! Glad you were able to sort it out. Next time..,
I'll be less presumptuous!<g>
Click to expand...

Hi Garry

Just out of interest , how would you add a colour (say Green) to the
word 'Open' in the Function code? I toyed with it but could find no
successful way. There seem to be many codes for colour implementation in
VBA, but none that work...


Function Get_ShopOpenStatus(CurrentTime As Variant) As String
Dim vShopOpens, vShopCloses
vShopOpens = TimeValue("8:00 AM")
vShopCloses = TimeValue("4:30 PM")
If TimeValue(Now) > vShopOpens And TimeValue(Now) < vShopCloses Then _
Get_ShopOpenStatus = "open." Else Get_ShopOpenStatus = "closed."
End Function


Thanks Garry.
 
G

GS

Colin Hayes presented the following explanation :
Hi Garry

Just out of interest , how would you add a colour (say Green) to the word
'Open' in the Function code? I toyed with it but could find no successful
way. There seem to be many codes for colour implementation in VBA, but none
that work...


Function Get_ShopOpenStatus(CurrentTime As Variant) As String
Dim vShopOpens, vShopCloses
vShopOpens = TimeValue("8:00 AM")
vShopCloses = TimeValue("4:30 PM")
If TimeValue(Now) > vShopOpens And TimeValue(Now) < vShopCloses Then _
Get_ShopOpenStatus = "open." Else Get_ShopOpenStatus = "closed."
End Function


Thanks Garry.
Click to expand...

Well, I think you're gonna have to look at getting involved with
multiple properties and lots of character manipulation. I've never had
any need to do this programmatically so try doing it manually with the
macro recorder and see what, if any, code generates.

You might be better off just setting the cell's font to green for times
that fall into open hours.
 
G

GS

Colin,
I see that the macro recorder gives you everything you need for this.
What you might want to do is add a global variable (g_bOpenHours) to
manage the font coloring...

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo stoppit
Application.EnableEvents = False
If Me.Range("D4").Value <> "" Then
With Sheets("ShareSheet")
.Unprotect Password:="password"
.Range("A21").Value = "Last Updated: " _
& Format(Now, " dddd dd/mm/yy at hh:mm:ss") _
& ", when the shop was " & Get_ShopOpenStatus(TimeValue(Now))

If g_bOpenHours Then Call FlagOpenHours
stoppit:
.Protect Password:="password"
End With
End If
Application.EnableEvents = True
End Sub

In a standard module:

Option Explicit

Public g_bOpenHours As Boolean


Sub FlagOpenHours()
Dim iPos As Integer
If g_bOpenHours Then
With ActiveSheet.Range("A21")
iPos = InStr(1, .Value, "open", vbTextCompare)
.Characters(Start:=iPos, Length:=4).Font.ColorIndex = 10
End With
g_bOpenHours = False '//reset flag
End If
End Sub

Function Get_ShopOpenStatus(CurrentTime As Variant) As String
Dim vShopOpens, vShopCloses
vShopOpens = TimeValue("8:00 AM")
vShopCloses = TimeValue("4:30 PM")
If CurrentTime > vShopOpens And CurrentTime < vShopCloses Then
Get_ShopOpenStatus = "open.": g_bOpenHours = True '//turn flag ON
Else
Get_ShopOpenStatus = "closed."
End If
End Function
 
C

Colin Hayes

Well, I think you're gonna have to look at getting involved with multiple properties
and lots of
character manipulation. I've never had any need to do this programmatically so try
doing it manually
with the macro recorder and see what, if any, code generates.

You might be better off just setting the cell's font to green for times that fall into
open hours.
Click to expand...

Hi Garry

OK thanks for that. I do now realise that colour is complicated. I've
seen your further message , and will have a go at this. Very
interesting.

I made an error in my earlier email. Or rather overlooked a parameter.
Apologies.

My 'shop' is closed at weekends , so the TimeValue in the function would
need to return 'Closed' on Saturdays and Sundays.

Function Get_ShopOpenStatus(CurrentTime As Variant) As String
Dim vShopOpens, vShopCloses
vShopOpens = TimeValue("8:00 AM")
vShopCloses = TimeValue("4:30 PM")
If CurrentTime > vShopOpens And CurrentTime < vShopCloses Then _
Get_ShopOpenStatus = "open." Else Get_ShopOpenStatus = "closed."
End Function

I'm trying to include a 'Weekday' function in the code presently.



Best Wishes


Colin
 
G

GS

In the code behind the worksheet:

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo stoppit
Application.EnableEvents = False
If Me.Range("D4").Value <> "" Then
With Sheets("ShareSheet")
.Unprotect Password:="password"
.Range("A21").Value = "Last Updated: " _
& Format(Now, " dddd dd/mm/yy at hh:mm:ss") _
& ", when the shop was " & Get_ShopOpenStatus(TimeValue(Now))

If g_bOpenHours Then Call FlagOpenHours(Sheets("ShareSheet"))
stoppit:
.Protect Password:="password"
End With
End If
Application.EnableEvents = True
End Sub


In a standard module:

Option Explicit

Public g_bOpenHours As Boolean


Sub FlagOpenHours(Optional Wks As Worksheet)
Dim iPos As Integer
If Wks Is Nothing Then Set Wks = ActiveSheet
If g_bOpenHours Then
With Wks.Range("A21")
iPos = InStr(1, .Value, "open", vbTextCompare)
.Characters(Start:=iPos, Length:=4).Font.ColorIndex = 10
End With
g_bOpenHours = False '//reset flag
End If
End Sub

Function Get_ShopOpenStatus(CurrentTime As Variant) As String
Dim vShopOpens, vShopCloses
vShopOpens = TimeValue("8:00 AM")
vShopCloses = TimeValue("4:30 PM")
If CurrentTime > vShopOpens And CurrentTime < vShopCloses _
And Weekday(CurrentTime) > 1 And Weekday(CurrentTime) < 7 Then
Get_ShopOpenStatus = "open.": g_bOpenHours = True '//turn flag ON
Else
Get_ShopOpenStatus = "closed."
End If
End Function
 
C

Colin Hayes

In the code behind the worksheet:

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo stoppit
Application.EnableEvents = False
If Me.Range("D4").Value <> "" Then
With Sheets("ShareSheet")
.Unprotect Password:="password"
.Range("A21").Value = "Last Updated: " _
& Format(Now, " dddd dd/mm/yy at hh:mm:ss") _
& ", when the shop was " & Get_ShopOpenStatus(TimeValue(Now))

If g_bOpenHours Then Call FlagOpenHours(Sheets("ShareSheet"))
stoppit:
.Protect Password:="password"
End With
End If
Application.EnableEvents = True
End Sub


In a standard module:

Option Explicit

Public g_bOpenHours As Boolean


Sub FlagOpenHours(Optional Wks As Worksheet)
Dim iPos As Integer
If Wks Is Nothing Then Set Wks = ActiveSheet
If g_bOpenHours Then
With Wks.Range("A21")
iPos = InStr(1, .Value, "open", vbTextCompare)
.Characters(Start:=iPos, Length:=4).Font.ColorIndex = 10
End With
g_bOpenHours = False '//reset flag
End If
End Sub

Function Get_ShopOpenStatus(CurrentTime As Variant) As String
Dim vShopOpens, vShopCloses
vShopOpens = TimeValue("8:00 AM")
vShopCloses = TimeValue("4:30 PM")
If CurrentTime > vShopOpens And CurrentTime < vShopCloses _
And Weekday(CurrentTime) > 1 And Weekday(CurrentTime) < 7 Then
Get_ShopOpenStatus = "open.": g_bOpenHours = True '//turn flag ON
Else
Get_ShopOpenStatus = "closed."
End If
End Function
Click to expand...

Hi Garry

OK Thanks for that - Working perfectly.

I've managed to follow the logic of your procedures here. Very
impressive.



Best Wishes


Colin
 

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

Reverse Index Match 2
Help with time formats in Excel 2007, 0
Daily cumulative timesheet entries 0
Suming Up Time over the course of days 1
15 minute data to daily data 1
Need to pull <=14 Days, <=30 Days, >30 Days from a date column 3
Countif Function?? 3
Formating time 2

Top