PDA

View Full Version : How can I speedUP my events based procedure?



Krystian_B
09-24-2014, 02:29 AM
Hi, I have huge problem with my event procedure, it takes ages to run when i want to change more than few cells at once. How it works, well when user changes data in cell the Worksheet_Change adds comments, but first the Worksheet_SelectionChange updates informations for user (i have sumifs in different worksheet where it calculates ACT data for 12 months, and then it display via camer tool on active worksheet).

In know that problem is cuz of constant looping through events.... duno what to do ?!


Thx for help! :bow:




Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range
ActiveSheet.Unprotect Password:="xyz"
For Each cell In Target
If cell.Row > 21 And cell.Column > 9 Then
If cell.Comment Is Nothing Then
cell.AddComment Now & " - " & cell.Value & " - " & Application.UserName
Else
If Val(Len(cell.Comment.Text)) > 255 Then
cell.Comment.Delete
cell.AddComment
cell.Comment.Text _
Now & " - " & cell.Value & " - " & Application.UserName, 1, False
Else
cell.Comment.Text _
vbNewLine & Now & " - " & cell.Value & " - " & Application.UserName, Len(cell.Comment.Text) + 1, False
End If
End If
cell.Comment.Shape.TextFrame.AutoSize = True
End If
Next cell
ActiveSheet.Protect Password:="11opkLnm890", AllowFiltering:=True
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim RowNumber As Long, i As Long
Dim MaxRowNumber As Long
MaxRowNumber = Range("A9").Value
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
RowNumber = Target.Row
Set sh_AUXILIARY_PT = ThisWorkbook.Worksheets("AUXILIARY_PT")
If Target.Row > 21 And Target.Row < MaxRowNumber Then
sh_AUXILIARY_PT.Range("AA4").Value = Cells(RowNumber, 1).Value
sh_AUXILIARY_PT.Range("AB4").Value = Cells(RowNumber, 2).Value
sh_AUXILIARY_PT.Range("AC4").Value = Cells(RowNumber, 3).Value
sh_AUXILIARY_PT.Range("AD4").Value = Cells(RowNumber, 4).Value
For i = 14 To 25
sh_AUXILIARY_PT.Cells(8, i).Value = Cells(RowNumber, i - 4).Value
Next i
End If
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

Kenneth Hobs
09-24-2014, 06:52 AM
Welcome to the forum! Please use code tags and paste code between them. Click the # icon to add the codes quickly.

Not sure it will help but try adding your Application lines of code to your first Sub as you did the second. In a like manner to help speedup code, see my kb article: http://vbaexpress.com/kb/getarticle.php?kb_id=1035

You may want to consider using Environ("username") rather than Application.Name. Main thing is to understand the difference in the two methods when using one over the other.

Tip: In ThisWorkbook object, add the sheet Protect in it with the UserInterfaceOnly option. This allows code to modify without setting/resetting the sheet password.

e.g.

Private Sub Workbook_Open()
Dim ws As Worksheet
For Each ws In Worksheets
ws.Protect "ken", UserInterfaceOnly:=True 'True allows code to change data.
Next ws
End Sub

p45cal
09-24-2014, 10:48 AM
see if these speed thing up at all:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range, RangeToExamine As Range
Set RangeToExamine = Intersect(Target, Range(Cells(22, 10), UsedRange.Cells(UsedRange.Cells.Count)))
Unprotect Password:="xyz"
If Not RangeToExamine Is Nothing Then
For Each cell In RangeToExamine
With cell
If .Comment Is Nothing Then
.AddComment Now & " - " & .Value & " - " & Application.UserName
.Comment.Shape.TextFrame.AutoSize = True
Else
If Len(.Comment.Text) > 255 Then
.Comment.Delete
.AddComment
.Comment.Text Now & " - " & .Value & " - " & Application.UserName, 1, False
.Comment.Shape.TextFrame.AutoSize = True
Else
.Comment.Text vbNewLine & Now & " - " & .Value & " - " & Application.UserName, Len(.Comment.Text) + 1, False
.Comment.Shape.TextFrame.AutoSize = True
End If
End If
End With
Next cell
End If
Protect Password:="11opkLnm890", AllowFiltering:=True
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim RowNumber As Long, i As Long
Dim MaxRowNumber As Long
RowNumber = Target.Row
If RowNumber > 21 Then
If RowNumber < Range("A9").Value Then
'Application.ScreenUpdating = False' unlikely to be needed.
Application.Calculation = xlCalculationManual
Application.EnableEvents = False 'may not be needed.
With ThisWorkbook.Worksheets("AUXILIARY_PT")
.Range("AA4:AD4").Value = Cells(RowNumber, 1).Resize(, 4).Value
.Range("N8:Y8").Value = Cells(RowNumber, 10).Resize(, 12).Value
End With
Application.EnableEvents = True
'Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End If
End If
End Sub

p45cal
09-24-2014, 12:07 PM
Another suggestion, I see that that you're creating a history in a cell's comment, and when that comment gets to be longer than 255 characters you delete the entire history and start afresh. Should you want to keep the length of the comment down and retain a bit more history, the following code will erase the oldest lines of history one at a time until the length of the comment gets down to 255 characters or less, then adds the newest line:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range, RangeToExamine As Range
Set RangeToExamine = Intersect(Target, Range(Cells(22, 10), UsedRange.Cells(UsedRange.Cells.Count)))
Unprotect Password:="xyz"
If Not RangeToExamine Is Nothing Then
For Each cell In RangeToExamine
With cell
If .Comment Is Nothing Then
.AddComment Now & " - " & .Value & " - " & Application.UserName
.Comment.Shape.TextFrame.AutoSize = True
Else
If Len(.Comment.Text) > 255 Then
Do
If InStr(1, .Comment.Text, vbLf, vbTextCompare) > 0 Then
.Comment.Text Text:=Mid(.Comment.Text, InStr(1, .Comment.Text, vbLf, vbTextCompare) + 1)
Else
.Comment.Delete
.AddComment
End If
Loop Until Len(.Comment.Text) <= 255
.Comment.Text IIf(Len(.Comment.Text) > 0, vbLf, "") & Now & " - " & .Value & " - " & Application.UserName, Len(.Comment.Text) + 1, False
.Comment.Shape.TextFrame.AutoSize = True
Else
.Comment.Text vbLf & Now & " - " & .Value & " - " & Application.UserName, Len(.Comment.Text) + 1, False
.Comment.Shape.TextFrame.AutoSize = True
End If
End If
End With
Next cell
End If
Protect Password:="11opkLnm890", AllowFiltering:=True
End Sub

Paul_Hossler
09-24-2014, 05:00 PM
You could disable events and screen updating in WS_Change to see if it helps


'--------------------------------------------------------------
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
'--------------------------------------------------------------




Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range
ActiveSheet.Unprotect Password:="xyz"
'--------------------------------------------------------------
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
'--------------------------------------------------------------

For Each cell In Target
If cell.Row > 21 And cell.Column > 9 Then
If cell.Comment Is Nothing Then
cell.AddComment Now & " - " & cell.Value & " - " & Application.UserName
Else
If Val(Len(cell.Comment.Text)) > 255 Then
cell.Comment.Delete
cell.AddComment
cell.Comment.Text _
Now & " - " & cell.Value & " - " & Application.UserName, 1, False
Else
cell.Comment.Text _
vbNewLine & Now & " - " & cell.Value & " - " & Application.UserName, Len(cell.Comment.Text) + 1, False
End If
End If
cell.Comment.Shape.TextFrame.AutoSize = True
End If
Next cell
'--------------------------------------------------------------
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
'--------------------------------------------------------------

ActiveSheet.Protect Password:="11opkLnm890", AllowFiltering:=True
End Sub


BTW -- I assume you realize the .Unprotect and .Protect PW are different

SamT
09-25-2014, 04:54 AM
The Selection Change Sub will never be so slow that it is noticable. You can make it a bit faster with copy and Paste Special and Transpose, but...

The looping in the Worksheet Change sub can really be sped up.

Mixing and matching everybody elses contributions, I may have added a little speed.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range
Dim RangeOfResponsibility As Range
Dim CellsToCheck As Range
Dim History As String

'ActiveSheet.Unprotect 'Follow Ken's advice in post #2

Set RangeOfResponsibility = Range(Cells(21, 9), Cells(Rows.Count, Columns.Count))

'If possible, Do nothing
If Intersect(Target, RangeOfResponsibility) Is Nothing Then Exit Sub

'--------------------------------------------------------------
'A little more speed from Paul's very important contribution.
With Application
.ScreenUpdating = False
Calculation = xlCalculationManual
.EnableEvents = False
End With
'--------------------------------------------------------------

'Do as little as possible
Set CellsToCheck = Intersect(Target, RangeOfResponsibility)

'p45cal's algorithm, highly modified for speed.
For Each cell In CellsToCheck
With cell

History = Now & " - " & .Value & " - " & Application.UserName
'Assumption: The length of the String above will never be longer than 255 characters

'Check most common state first
If Not .Comment Is Nothing Then
'Keep oldest history at beginning of Comment.
History = .Comment.Text & vbLf & History

'Work away from the cell as much as possible
Do While Len(History) > 255
History = Mid(History, InStr(1, History, vbLf, vbTextCompare) + 1)
Loop
Else: .AddComment
End If

.Comment.Text History
.Comment.Shape.TextFrame.AutoSize = True
End With
Next cell

'--------------------------------------------------------------
With Application
.EnableEvents = True
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
'--------------------------------------------------------------

End Sub

To put the History in the comment with the newest history at the beginning of the comment, subsitute these two lines in the code above

History = History & vbLf & .Comment.Text
History = Left(History, InStrRev(History, vbLf, -1, vbTextCompare) - 1)

Bob Phillips
09-25-2014, 06:31 AM
BTW -- I assume you realize the .Unprotect and .Protect PW are different

LOL, that's gonna work well!