Speed up this macro

[already]

Hi,

I have the following macro to copy and paste a range (never with the same lenght) but it is running slow and I receive an 'excel not responding' message.
The end result is always OK.

How can I speed up this macro?

Thanks in advance for your help.

Kind regards

Al

Sub aantal()
Application.ScreenUpdating = False
Range("b2", Range("b2").End(xlDown)).Cut

Range("s2").Select
ActiveSheet.Paste
Range("c2", Range("c" & Rows.Count).End(xlDown)).Cut

Range("b2").Select

ActiveSheet.Paste
Application.ScreenUpdating = True
End Sub

 

[Comfy]

Try this:

Sub aantal()
Application.ScreenUpdating = False


Range("B2", Range("B2").End(xlDown)).Cut Range("S2")


Range("C2", Range("C2").End(xlDown)).Cut Range("B2")


Application.ScreenUpdating = True
End Sub

 

[Mindpsyche]

Hi try this on a copy of your worksheet. This code will find the last non empty cell in Column B and use that cell as the last cell in the range to be copied from column B to column S. The same approach is used for Column C to Column B.

Sub Cuttest()
    Dim r As Range, lrb As Long, lrc As Long
    
        lrb = Range("B" & Rows.Count).End(xlUp).Row 'Determine last non empty cell in Column B
        lrc = Range("C" & Rows.Count).End(xlUp).Row 'Determine last non empty cell in Column C
        
                'Copy from B column to S column
                Range("S2:S" & lrb).Value = Range("B2:B" & lrb).Value
                
                'Clear B column
                Range("B2:B" & lrb).ClearContents
                
                'Copy from column C to column B
                Range("B2:B" & lrc).Value = Range("C2:C" & lrc).Value
                
                'Clear column c
                Range("C2:C" & lrc).ClearContents
End Sub

 

[already]

Hi,

Thanks both for your help!!! The solution from Comfy did not copy all the data from column C to B. Only the first 3 lines ???

Mindpsyche your code did it and is very fast.

Kind regards

Al