Multiple worksheet change events slowing down workbook

[tykoom]

I have written some VBA code which contains multiple worksheet change event triggers within a single sheet. It works as I would like it to however I find it has slowed my workbook down whenever I make any changes to it. I wondered if there is a more efficient way to write this code? See code below - the purpose is that if a user changes a cell value within a number of ranges, it concatenates the values from that range into another cell. Any advice would be much appreciated.

Private Sub Worksheet_Change(ByVal target As Range)
    Set myCell = Sheet5.Range("E13")
    If Not Intersect(target, Range("X24:X28")) Is Nothing Then
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Application.DisplayStatusBar = False
    Application.EnableEvents = False
    Set rng = Range("X24:X28")
    myCell.Value = ""
    For Each Cell In rng
        If Cell.Value <> "" Then
            myCell.Value = myCell.Value & Cell.Value & vbNewLine
    End If
    Next
    End If
    If myCell.Value <> "" Then myCell.Value = Left(myCell.Value, Len(myCell.Value) - 1)


    Set myCell = Sheet5.Range("E14")
    If Not Intersect(target, Range("X35:X40")) Is Nothing Then
    Set rng = Range("X35:X40")
    myCell.Value = ""
    For Each Cell In rng
        If Cell.Value <> "" Then
            myCell.Value = myCell.Value & Cell.Value & vbNewLine
    End If
    Next
    End If
    If myCell.Value <> "" Then myCell.Value = Left(myCell.Value, Len(myCell.Value) - 1)


    Set myCell = Sheet5.Range("E15")
    If Not Intersect(target, Range("X47:X51")) Is Nothing Then
    Set rng = Range("X47:X51")
    myCell.Value = ""
    For Each Cell In rng
        If Cell.Value <> "" Then
            myCell.Value = myCell.Value & Cell.Value & vbNewLine
    End If
    Next
    End If
    If myCell.Value <> "" Then myCell.Value = Left(myCell.Value, Len(myCell.Value) - 1)


    Set myCell = Sheet5.Range("E16")
    If Not Intersect(target, Range("X58:X63")) Is Nothing Then
    Set rng = Range("X58:X63")
    myCell.Value = ""
    For Each Cell In rng
        If Cell.Value <> "" Then
            myCell.Value = myCell.Value & Cell.Value & vbNewLine
    End If
    Next
    End If
    If myCell.Value <> "" Then myCell.Value = Left(myCell.Value, Len(myCell.Value) - 1)


    Set myCell = Sheet5.Range("E17")
    If Not Intersect(target, Range("X70:X77")) Is Nothing Then
    Set rng = Range("X70:X77")
    myCell.Value = ""
    For Each Cell In rng
        If Cell.Value <> "" Then
            myCell.Value = myCell.Value & Cell.Value & vbNewLine
    End If
    Next
    End If
    If myCell.Value <> "" Then myCell.Value = Left(myCell.Value, Len(myCell.Value) - 1)


    Set myCell = Sheet5.Range("E18")
    If Not Intersect(target, Range("X84:X93")) Is Nothing Then
    Set rng = Range("X84:X93")
    myCell.Value = ""
    For Each Cell In rng
        If Cell.Value <> "" Then
            myCell.Value = myCell.Value & Cell.Value & vbNewLine
    End If
    Next
    End If
    If myCell.Value <> "" Then myCell.Value = Left(myCell.Value, Len(myCell.Value) - 1)


    Set myCell = Sheet5.Range("E19")
    If Not Intersect(target, Range("X100:X106")) Is Nothing Then
    Set rng = Range("X100:X106")
    myCell.Value = ""
    For Each Cell In rng
        If Cell.Value <> "" Then
            myCell.Value = myCell.Value & Cell.Value & vbNewLine
    End If
    Next
    End If
    If myCell.Value <> "" Then myCell.Value = Left(myCell.Value, Len(myCell.Value) - 1)

    Set myCell = Sheet5.Range("E20")
    If Not Intersect(target, Range("X113:X117")) Is Nothing Then
    Set rng = Range("X113:X117")
    myCell.Value = ""
    For Each Cell In rng
        If Cell.Value <> "" Then
            myCell.Value = myCell.Value & Cell.Value & vbNewLine
    End If
    Next
    End If
    If myCell.Value <> "" Then myCell.Value = Left(myCell.Value, Len(myCell.Value) - 1)


    Set myCell = Sheet5.Range("E22")
    If Not Intersect(target, Range("I121")) Is Nothing Then
    Set rng = Range("I121")
    myCell.Value = ""
    For Each Cell In rng
        If Cell.Value <> "" Then
            myCell.Value = Cell.Value
    End If
    Next
    End If
    If myCell.Value <> "" Then myCell.Value = Left(myCell.Value, Len(myCell.Value) - 1)

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True

End Sub

 

[Fluff]

Hi & welcome to MrExcel.
Why not just use a formula?
In E13 it would be

=TEXTJOIN(CHAR(10),,X24:X28)

 

[tykoom]

Hi & welcome to MrExcel.
Why not just use a formula?
In E13 it would be

=TEXTJOIN(CHAR(10),,X24:X28)

Hi, thanks for your reply + welcome - I should have clarified this in my original post. I need the concatenated text in the destination cell to be editable by users so I don't want a formula in there, hence using VBA.

 

[Fluff]

Ok, you can try it like

Private Sub Worksheet_Change(ByVal Target As Range)

   If Not Intersect(Target, Range("X24:X28,X35:X40,X47:X51")) Is Nothing Then
      Application.Calculation = xlCalculationManual
      Application.ScreenUpdating = False
      Application.DisplayStatusBar = False
      Application.EnableEvents = False
      If Not Intersect(Target, Range("X24:X28")) Is Nothing Then
         Range("E13").Value = Application.TextJoin(Chr(10), , Range("X24:X28"))
      ElseIf Not Intersect(Target, Range("X35:X40")) Is Nothing Then
         Range("E14").Value = Application.TextJoin(Chr(10), , Range("X35:X40"))
      ElseIf Not Intersect(Target, Range("X47:X51")) Is Nothing Then
         Range("E15").Value = Application.TextJoin(Chr(10), , Range("X47:X51"))
      End If
   End If
   
   Application.Calculation = xlCalculationAutomatic
   Application.ScreenUpdating = True
   Application.DisplayStatusBar = True
   Application.EnableEvents = True

End Sub

 

[tykoom]

Ok, you can try it like

Private Sub Worksheet_Change(ByVal Target As Range)

   If Not Intersect(Target, Range("X24:X28,X35:X40,X47:X51")) Is Nothing Then
      Application.Calculation = xlCalculationManual
      Application.ScreenUpdating = False
      Application.DisplayStatusBar = False
      Application.EnableEvents = False
      If Not Intersect(Target, Range("X24:X28")) Is Nothing Then
         Range("E13").Value = Application.TextJoin(Chr(10), , Range("X24:X28"))
      ElseIf Not Intersect(Target, Range("X35:X40")) Is Nothing Then
         Range("E14").Value = Application.TextJoin(Chr(10), , Range("X35:X40"))
      ElseIf Not Intersect(Target, Range("X47:X51")) Is Nothing Then
         Range("E15").Value = Application.TextJoin(Chr(10), , Range("X47:X51"))
      End If
   End If
  
   Application.Calculation = xlCalculationAutomatic
   Application.ScreenUpdating = True
   Application.DisplayStatusBar = True
   Application.EnableEvents = True

End Sub

This works perfectly and is much faster now - thank you very much!

 

[Fluff]

You're welcome & thanks for the feedback.

 

[tykoom]

So I’ve shared my workbook with another user but this won’t run for them - they are using 2016 Excel, and other potential users may have even older versions. I’m assuming that TEXTJOIN is the problem here and I will have to avoid it. I don’t suppose you have any other advice for improving my code without it?

 

[Fluff]

Ok, how about

Private Sub Worksheet_Change(ByVal Target As Range)
   Dim Ary As Variant
   
   If Not Intersect(Target, Range("X24:X28,X35:X40,X47:X51")) Is Nothing Then
      Application.Calculation = xlCalculationManual
      Application.ScreenUpdating = False
      Application.DisplayStatusBar = False
      Application.EnableEvents = False
      If Not Intersect(Target, Range("X24:X28")) Is Nothing Then
         Ary = Filter(Evaluate("transpose(if(X24:X28<>"""",X24:X28,false))"), False, False)
         Range("E13").Value = Join(Ary, vbLf)
      ElseIf Not Intersect(Target, Range("X35:X40")) Is Nothing Then
         Ary = Filter(Evaluate("transpose(if(X35:X40<>"""",X35:X40,false))"), False, False)
         Range("E14").Value = Join(Ary, vbLf)
      ElseIf Not Intersect(Target, Range("X47:X51")) Is Nothing Then
         Ary = Filter(Evaluate("transpose(if(X47:X51<>"""",X47:X51,false))"), False, False)
         Range("E15").Value = Join(Ary, vbLf)
      End If
   End If
   
   Application.Calculation = xlCalculationAutomatic
   Application.ScreenUpdating = True
   Application.DisplayStatusBar = True
   Application.EnableEvents = True

End Sub

 

[tykoom]

This works well and is compatible with earlier versions of Excel. Many thanks again for your help!

 

[Fluff]

You're welcome & thanks for the feedback.