Slow code

[Jock]

I have looked in past posts but been unable to find something to speed up
this code.
The worksheet has a number of codes doing different things: entering date in
P when initials are put in O; putting everything in uppercase, for example.
The problem I have though seems to be with code which, when something is
entered in D, will automatically enter the date in B and the time in C. The
cell in B is also automatically coloured depending on the day of the week.
Although the time appears instantly, it then takes about 4 or 5 secs for
the date and colour to appear in B. In the status bar at the bottom, a
percentage bar trickles up during the 5 secs delay.

Rather than strip the code down to show just this, I have included the
whole thing as someone may have a solution.

Private Sub Worksheet_Change(ByVal Target As Range)

' Forces uppercase on selectes ranges
Application.EnableEvents = False
If Not Application.Intersect(Target,
Me.Range("D7:J5000,P7:Q5000,T7:U5000,X7:AA5000")) Is Nothing Then
Target(1).Value = StrConv(Target(1).Value, vbUpperCase)
End If
Application.EnableEvents = True


' Enters date & time automatically in B & C when text entered in D
On Error GoTo ws_exit:
Application.EnableEvents = False
If Not Intersect(Target, Me.Range("D75000")) Is Nothing Then
With Target
If .Value <> "" Then
.Offset(0, -1).Value = Format(Now, "hh:mm:ss")
Application.EnableEvents = True
.Offset(0, -2).Value = Format(Date, "dd/mmm")
End If
End With
End If

' Enters date automatically in R when text entered in Q
On Error GoTo ws_exit:
Application.EnableEvents = False
If Not Intersect(Target, Me.Range("Q7:Q5000")) Is Nothing Then
With Target
If .Value <> "" Then
'.Offset(0, -1).Value = Format(Now, "hh:mm:ss")
Application.EnableEvents = True
.Offset(0, 1).Value = Format(Date, "dd/mmm")
End If
End With
End If

' Enters date automatically in V when text entered in U
On Error GoTo ws_exit:
Application.EnableEvents = False
If Not Intersect(Target, Me.Range("U7:U5000")) Is Nothing Then
With Target
If .Value <> "" Then
'.Offset(0, -1).Value = Format(Now, "hh:mm:ss")
Application.EnableEvents = True
.Offset(0, 1).Value = Format(Date, "dd/mmm")
End If
End With
End If

' Colours column B depending on day of the week
If Not Intersect(Target, Me.Range("B7:B5000")) Is Nothing Then
With Target
Select Case Application.Weekday(.Value, 2)
Case 1: .Interior.ColorIndex = 15
Case 2: .Interior.ColorIndex = 45
Case 3: .Interior.ColorIndex = 38
Case 4: .Interior.ColorIndex = 50
Case 5: .Interior.ColorIndex = 44
End Select
End With
End If

ws_exit:
Application.EnableEvents = True
End Sub


Thanks for any replies

 

[Jim Cone]

Jock,
Remove or comment out all of the "Application.EnableEvents = True"
statements except for the very last one.

Also, add the following as the second line of your code...
On Error GoTo ws_exit
--
Jim Cone
San Francisco, USA
http://www.realezsites.com/bus/primitivesoftware
(Excel Add-ins / Excel Programming)




"Jock"
wrote in message
I have looked in past posts but been unable to find something to speed up
this code.
The worksheet has a number of codes doing different things: entering date in
P when initials are put in O; putting everything in uppercase, for example.
The problem I have though seems to be with code which, when something is
entered in D, will automatically enter the date in B and the time in C. The
cell in B is also automatically coloured depending on the day of the week.
Although the time appears instantly, it then takes about 4 or 5 secs for
the date and colour to appear in B. In the status bar at the bottom, a
percentage bar trickles up during the 5 secs delay.

Rather than strip the code down to show just this, I have included the
whole thing as someone may have a solution.

Private Sub Worksheet_Change(ByVal Target As Range)

' Forces uppercase on selectes ranges
Application.EnableEvents = False
If Not Application.Intersect(Target,
Me.Range("D7:J5000,P7:Q5000,T7:U5000,X7:AA5000")) Is Nothing Then
Target(1).Value = StrConv(Target(1).Value, vbUpperCase)
End If
Application.EnableEvents = True


' Enters date & time automatically in B & C when text entered in D
On Error GoTo ws_exit:
Application.EnableEvents = False
If Not Intersect(Target, Me.Range("D75000")) Is Nothing Then
With Target
If .Value <> "" Then
.Offset(0, -1).Value = Format(Now, "hh:mm:ss")
Application.EnableEvents = True
.Offset(0, -2).Value = Format(Date, "dd/mmm")
End If
End With
End If

' Enters date automatically in R when text entered in Q
On Error GoTo ws_exit:
Application.EnableEvents = False
If Not Intersect(Target, Me.Range("Q7:Q5000")) Is Nothing Then
With Target
If .Value <> "" Then
'.Offset(0, -1).Value = Format(Now, "hh:mm:ss")
Application.EnableEvents = True
.Offset(0, 1).Value = Format(Date, "dd/mmm")
End If
End With
End If

' Enters date automatically in V when text entered in U
On Error GoTo ws_exit:
Application.EnableEvents = False
If Not Intersect(Target, Me.Range("U7:U5000")) Is Nothing Then
With Target
If .Value <> "" Then
'.Offset(0, -1).Value = Format(Now, "hh:mm:ss")
Application.EnableEvents = True
.Offset(0, 1).Value = Format(Date, "dd/mmm")
End If
End With
End If

' Colours column B depending on day of the week
If Not Intersect(Target, Me.Range("B7:B5000")) Is Nothing Then
With Target
Select Case Application.Weekday(.Value, 2)
Case 1: .Interior.ColorIndex = 15
Case 2: .Interior.ColorIndex = 45
Case 3: .Interior.ColorIndex = 38
Case 4: .Interior.ColorIndex = 50
Case 5: .Interior.ColorIndex = 44
End Select
End With
End If

ws_exit:
Application.EnableEvents = True
End Sub


Thanks for any replies

 

[Jock]

Thanks for the reply Jim, but that didn't make any difference. I am confused
because, if I comment out the line which puts the date in column B, it works
in a flash. If I comment out the time bit and put back the date, it takes 4
or 5 secs, so it's got to be something to do with the date part but I don't
know what!

Cheers,

 

[Gary Keramidas]

not sure, but you can try turning off screenupdating and calculation
ad this to the beginning:

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

and this to the end:

Application.ScreenUpdating =True
Application.Calculation = xlCalculationAutomatic

 

[James Snell]

It sounds like something you're doing is causing a recalc.

It's worth confirming that it is putting a date into column b, just setup a
test macro to just populate a date there & see what happens. Do you have
something in the formulae in the workbook that relies on a lot of processing