VBA Code very slow. How can it be sped up?

Aretradeser

Board Regular
Joined
Jan 16, 2013
Messages
173
Office Version
  1. 2013
Platform
  1. Windows
I use this code (CODE 1) to copy data from one Excel sheet to another; but it is very slow. How can I speed it up?
In the sheet where I paste the data (Sheet7), I have this other code (CODE 2), which I think is responsible for the slowness of CODE 1.
CODE 1
CSS:
Sub CopyPaste()
    Application.ScreenUpdating = False
    Sheets("Hoja6").Select
    Range("A2:I4678").Select
    Selection.Copy
    Sheets("Hoja7").Select
    Range("B2").Select
    ActiveSheet.Paste
    Application.ScreenUpdating = True
End Sub
CODE 2
Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ultimaFila, filaID, ultimoCodigo As Integer
ultimaFila = Sheets("Hoja7").Range("B" & Rows.Count).End(xlUp).Row
filaID = Sheets("Hoja7").Range("A" & Rows.Count).End(xlUp).Row
    If (ultimaFila > filaID) Then
        If (filaID = 1) Then
            ultimoCodigo = 1
        Else
            ultimoCodigo = Sheets("Hoja7").Range("A" & filaID).Value + 1
        End If
        Sheets("Hoja7").Range("A" & filaID + 1).Value = ultimoCodigo
End If
End Sub
 
Can you show me your current code2 code ?
This is the current code:
CODE 2
VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ultimaFila, filaID, ultimoCodigo As Integer
ultimaFila = Sheets("Hoja7").Range("B" & Rows.Count).End(xlUp).Row
filaID = Sheets("Hoja7").Range("A" & Rows.Count).End(xlUp).Row
    If (ultimaFila > filaID) Then
        If (filaID = 1) Then
            ultimoCodigo = 1
        Else
            ultimoCodigo = Sheets("Hoja7").Range("A" & filaID).Value + 1
        End If
        Sheets("Hoja7").Range("A" & filaID + 1).Value = ultimoCodigo
End If
End Sub

I also used your code and it doesn't work either
Code:
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim ultimaFila As Long, filaID As Long
    Dim rngID As Range
    Application.EnableEvents = False
    Application.screenupdate = False
    
    ultimaFila = Sheets("Hoja7").Range("B" & Rows.Count).End(xlUp).Row
    filaID = Sheets("Hoja7").Range("A" & Rows.Count).End(xlUp).Row
    Set rngID = Range(Cells(filaID, "A"), Cells(ultimaFila, "B"))
    
        If (ultimaFila > filaID) Then
            If (filaID = 1) Then
                rngID.Cells(1, 1) = 1
            End If
            rngID.DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _
                    Step:=1, Trend:=False
        End If
        
    Application.EnableEvents = True
    Application.screenupdate = True
End Sub
 
Upvote 0

Excel Facts

How to find 2nd largest value in a column?
MAX finds the largest value. =LARGE(A:A,2) will find the second largest. =SMALL(A:A,3) will find the third smallest
Try the code below, it should be in the sheet module of Hoja7.

If it doesn't seem to do anything copy the next line into the immediate window and hit enter.
VBA Code:
    Application.EnableEvents = True


VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)

    Dim ultimaFila As Long, filaID As Long
    Dim rngID As Range
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    
    ultimaFila = Sheets("Hoja7").Range("B" & Rows.Count).End(xlUp).Row
    filaID = Sheets("Hoja7").Range("A" & Rows.Count).End(xlUp).Row
    Set rngID = Sheets("Hoja7").Range(Cells(filaID, "A"), Cells(ultimaFila, "B"))
    
    If Intersect(Target, Columns("A")) Is Nothing Then
        If (ultimaFila > filaID) Then
            If (filaID = 1) Then
                rngID.Cells(1, 1) = 1
            End If
            rngID.DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _
                    Step:=1, Trend:=False
        End If
    End If
        
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
Try the code below, it should be in the sheet module of Hoja7.

If it doesn't seem to do anything copy the next line into the immediate window and hit enter.
VBA Code:
    Application.EnableEvents = True


VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)

    Dim ultimaFila As Long, filaID As Long
    Dim rngID As Range
    Application.EnableEvents = False
    Application.ScreenUpdating = False
 
    ultimaFila = Sheets("Hoja7").Range("B" & Rows.Count).End(xlUp).Row
    filaID = Sheets("Hoja7").Range("A" & Rows.Count).End(xlUp).Row
    Set rngID = Sheets("Hoja7").Range(Cells(filaID, "A"), Cells(ultimaFila, "B"))
 
    If Intersect(Target, Columns("A")) Is Nothing Then
        If (ultimaFila > filaID) Then
            If (filaID = 1) Then
                rngID.Cells(1, 1) = 1
            End If
            rngID.DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _
                    Step:=1, Trend:=False
        End If
    End If
     
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
I put your code in the module of Sheet7 and run the following code (CODE 3), but there are still a lot of blank cells in column "A", it does not number them. It does nothing. As for copying that line of code into the next window, I don't know where exactly; since that line of code is already included in your recommended code. Which window are you referring to?
CODE 3
VBA Code:
Sub CopyPaste()
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Sheets("Hoja6").Select
    Range("A2:I4678").Select
    Selection.Copy
    Sheets("Hoja7").Select
    Range("B2").Select
    ActiveSheet.Paste
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
 
Last edited:
Upvote 0
Is sheet7 called Hoja7 ?
Also I did not intend the you to wrap your code1 now code3 in application.EnableEvents that was intended to go around your worksheet_change code.
Remove those 2 lines from your Code3
 
Last edited:
Upvote 0
There are likely two reasons your code is slow

1. You are using the 'select-do' method to copy the data. This is always slower than the 'do' method.
2. The copy operation is repeatedly triggering the worksheet change event code in the destination sheet (Sheets("Hoja7"))

I suspect #2 would have the larger effect. Also, if the copied data includes a lot of formulas, then recalculation time could also be a factor.

Did you ever try the recommended code I posted to this thread a couple of days ago?
 
Upvote 0
Also I did not intend the you to wrap your code1 now code3 in application.EnableEvents that was intended to go around your worksheet_change code.
Remove those 2 lines from your Code3
For that same reason you can't use rlv01's code:
Did you ever try the recommended code I posted to this thread a couple of days ago?

Since your design relies on the CopyPaste code to call the Worksheet_Change event, you can't turn off Enable Events in the CopyPaste procedure.
If you do your Worksheet_Change event won't kick in which seems to be your current issue.

So merging @My Aswer Is This & rlv01's code use this for the copy paste:
VBA Code:
Sub CopyPaste_rlv01()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
 
    Sheets("Hoja6").Range("A2:I4678").Copy Sheets("Hoja7").Range("B2")
 
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

Your existing Worksheet_Change event relies on it calling itself over and over again.
Which is a slow way of doing it.

1634168269251.png


Worksheet_Change event - Replace that code with this.
(slight modification on my previous code - to use the Me. object)
VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)

    Dim ultimaFila As Long, filaID As Long
    Dim rngID As Range
    Application.EnableEvents = False
    Application.ScreenUpdating = False

    ultimaFila = Me.Range("B" & Rows.Count).End(xlUp).Row
    filaID = Me.Range("A" & Rows.Count).End(xlUp).Row
    Set rngID = Me.Range(Me.Cells(filaID, "A"), Me.Cells(ultimaFila, "B"))

    If Intersect(Target, Me.Columns("A")) Is Nothing Then
        If (ultimaFila > filaID) Then
            If (filaID = 1) Then
                rngID.Cells(1, 1) = 1
            End If
            rngID.DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _
                    Step:=1, Trend:=False
        End If
    End If

    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
Solution
For that same reason you can't use rlv01's code:


Since your design relies on the CopyPaste code to call the Worksheet_Change event, you can't turn off Enable Events in the CopyPaste procedure.
If you do your Worksheet_Change event won't kick in which seems to be your current issue.

So merging @My Aswer Is This & rlv01's code use this for the copy paste:
VBA Code:
Sub CopyPaste_rlv01()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
 
    Sheets("Hoja6").Range("A2:I4678").Copy Sheets("Hoja7").Range("B2")
 
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

Your existing Worksheet_Change event relies on it calling itself over and over again.
Which is a slow way of doing it.

View attachment 49023

Worksheet_Change event - Replace that code with this.
(slight modification on my previous code - to use the Me. object)
VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)

    Dim ultimaFila As Long, filaID As Long
    Dim rngID As Range
    Application.EnableEvents = False
    Application.ScreenUpdating = False

    ultimaFila = Me.Range("B" & Rows.Count).End(xlUp).Row
    filaID = Me.Range("A" & Rows.Count).End(xlUp).Row
    Set rngID = Me.Range(Me.Cells(filaID, "A"), Me.Cells(ultimaFila, "B"))

    If Intersect(Target, Me.Columns("A")) Is Nothing Then
        If (ultimaFila > filaID) Then
            If (filaID = 1) Then
                rngID.Cells(1, 1) = 1
            End If
            rngID.DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _
                    Step:=1, Trend:=False
        End If
    End If

    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
Alex Blakenbur,
Thank you very much for your great help and the time you have taken to resolve the issue I have raised. I am very grateful for the help you and the rest of you who have contributed to this matter. You have saved me valuable time.
Thank you again, for this fabulous forum.
 
Upvote 0
When referring to columns it's always best to say column B or C saying column ID
May mean the column is named ID or maybe it has ID in row 1 of the column.
Either way it's harder for me to know what column your dealing with.
Now if we are referring to Table columns it best to say column 1 or column 3 of the Table named Table3

When referring to columns it's always best to say column B or C saying column ID
May mean the column is named ID or maybe it has ID in row 1 of the column.
Either way it's harder for me to know what column your dealing with.
Now if we are referring to Table columns it best to say column 1 or column 3 of the Table named Table3
My Aswer Is This,
Thank you very much for your great help and the time you have spent on this issue. I am very grateful for your collaboration.
 
Upvote 0
There are likely two reasons your code is slow

1. You are using the 'select-do' method to copy the data. This is always slower than the 'do' method.
2. The copy operation is repeatedly triggering the worksheet change event code in the destination sheet (Sheets("Hoja7"))

I suspect #2 would have the larger effect. Also, if the copied data includes a lot of formulas, then recalculation time could also be a factor.

Did you ever try the recommended code I posted to this thread a couple of days ago?
rlv01,
Thank you very much for your great help and the time you have spent on this issue. I am very grateful for your collaboration.
 
Upvote 0
Thank you for acknowledging everyone who pitched in and for letting us know that it resolved your issue.
Glad we could help.
 
Upvote 0

Forum statistics

Threads
1,213,489
Messages
6,113,947
Members
448,534
Latest member
benefuexx

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top