J
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
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