How can I speedUP my events based procedure?

[Krystian_B]

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!

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]

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]

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]

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]

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]

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]

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

LOL, that's gonna work well!