VBA to concatenate cells B&C into D, but then clear cell D if B&C are manually cleared - code running slow

[stacemc]

He All,
I've got the below VBA which concatenates cells B&C into D, but also clears cell D if B&C are manually cleared. It works but it is very slow. If I remove the if statement for clearing the cells the concatenate works perfectly fast by itself. I'm wondering on how to improve this so that the sheet isn't extremely slow but having both if statements. I am very new to VBA and worked this code out through google searches so please bare with me if this is a simple/obvious fix.

Sub CombineCols()

Dim oWS As Worksheet, lLastRow As Long, r As Long

Set oWS = ActiveSheet
lLastRow = oWS.Cells.SpecialCells(xlLastCell).row
For r = 3 To lLastRow
' Combine if both B and C are not empty
If Len(oWS.Cells(r, 2)) > 0 And Len(oWS.Cells(r, 3)) > 0 Then
oWS.Cells(r, 4).Value = "Endorced - " & oWS.Cells(r, 2).Value & " - " & oWS.Cells(r, 3).Value
End If
' Clear contents if both B and C are empty
If Len(oWS.Cells(r, 2)) = 0 And Len(oWS.Cells(r, 3)) = 0 Then
oWS.Cells(r, 4).Value = ClearContents
End If
Next
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("B3:C100")) Is Nothing Then
Call CombineCols
End If
End Sub

 

[Zot]

Try add Apllication.ScreenUpdating

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("B3:C100")) Is Nothing Then
Application.ScreenUpdating = False
Call CombineCols
Application.ScreenUpdating = True
End If
End Sub

 

[stacemc]

Try add Apllication.ScreenUpdating

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("B3:C100")) Is Nothing Then
Application.ScreenUpdating = False
Call CombineCols
Application.ScreenUpdating = True
End If
End Sub

Its still causing a significant delay in processing unfortunately. Just incase this is important - There is a large code within this workbook in the module section, I'm adding this code into the specific sheets code.

 

[Zot]

If changes trigger calculation, you want to delay the calculation until the end, else it will wait for calculation to finish before continue code run

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("B3:C100")) Is Nothing Then
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Call CombineCols
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End If
End Sub

It is always good to add those two lines to make code runs faster in most cases
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

 

[stacemc]

If changes trigger calculation, you want to delay the calculation until the end, else it will wait for calculation to finish before continue code run

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("B3:C100")) Is Nothing Then
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Call CombineCols
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End If
End Sub

It is always good to add those two lines to make code runs faster in most cases
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Ok that makes sense to delay the calculation. But now it doesn't run CombineCols at all - I'm guessing because it doesn't know when to do it? Do I need a button to trigger the code?

 

[Zot]

I see that this is the sheet change trigger event. Try to put calculation in the CombineCols sub

Sub CombineCols()

Dim oWS As Worksheet, lLastRow As Long, r As Long

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Set oWS = ActiveSheet
lLastRow = oWS.Cells.SpecialCells(xlLastCell).Row
For r = 3 To lLastRow
' Combine if both B and C are not empty
    If Len(oWS.Cells(r, 2)) > 0 And Len(oWS.Cells(r, 3)) > 0 Then
        oWS.Cells(r, 4).Value = "Endorced - " & oWS.Cells(r, 2).Value & " - " & oWS.Cells(r, 3).Value
    End If
' Clear contents if both B and C are empty
    If Len(oWS.Cells(r, 2)) = 0 And Len(oWS.Cells(r, 3)) = 0 Then
        oWS.Cells(r, 4).Value = ClearContents
    End If
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("B3:C100")) Is Nothing Then
    Call CombineCols
End If
End Sub