VBA - Very slow code - copy data from one sheet to another

[Pauline10]

Good morning to you all,

For starters pardon my English (I’m French)…

I’m also a beginner in VBA ?

I’m trying a VBA code that would allow the following :

I have a worksheet containing several sheets, each containing a table.

In one sheet "TEST", I would like, on command, to group the data from several sheets as long as the data is selected by inputting an “x” in columns AK :

• If “x” is found in column AK, copy cells from the associated line and from columns A to D and F to K
• Paste in sheet “TEST” at the last line of the table and starting in column B
• Replace the “x” by “ok”
• Not yet in code because already to slow : copy in “TEST”, and in column A, the name of the sheet from which the data has been copied. There are up to 5 sheets from which data could be copied. For the moment I've only tried with one sheet ("SGL")

I tested with 2 "x" in the sheet, and my problems are : 1. it only copies the first "x" and mostly 2. my code is very very very slow, I wonder if there’s a way to make it more efficient?

Sub bbbcd()


Sheets("SGL").Activate

For Each ce In ActiveSheet.Range("AK5:AK" & Cells(Rows.Count, 1).End(xlUp).Row)

If ce.Value = "x" Then

Dim range1 As Range, range2 As Range, multiplerange As Range
Set range1 = Range("A" & ce.Row & ":D" & ce.Row)
Set range2 = Range("F" & ce.Row & ":K" & ce.Row)
Set multiplerange = Union(range1, range2)

multiplerange.Copy Destination:=Sheets("Test").Cells(Rows.Count, 1).End(xlUp).Offset(1, 1)

ce.Value = "ok"

End If
Next ce

End Sub

(the first line in "TEST" has headers)

However by asking to copy the entire line instead of multiple ranges of cells, I manage to have all the data related to "x" pasted (below with 2 sheets) :

Sub bbbc()

Sheets("SGL").Activate

For Each ce In ActiveSheet.Range("AK5:AK" & Cells(Rows.Count, 1).End(xlUp).Row)
If ce.Value = "x" Then
ce.EntireRow.Copy Destination:=Sheets("Test").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
ce.Value = "ok"

End If
Next ce

Sheets("BPO").Activate

For Each ce In ActiveSheet.Range("AK5:AK" & Cells(Rows.Count, 1).End(xlUp).Row)
If ce.Value = "x" Then
ce.EntireRow.Copy Destination:=Sheets("Test").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
ce.Value = "ok"

End If
Next ce


End Sub

What do you think ? I would very much appreciate your help !

Have a good day,

Pauline

 

[Zot]

You do not need to activate or select worksheet. It can also slow down execution. Disable ScreenUpdating will make code much faster. If calculation invole like sheet has formula, disable calculation will also speed up code

Example how you can define sheet to make it easier to refer to sheet

Sub bbbc()

Dim wsSGL As Worksheet, wsBPO As Worksheet, wsTest As Worksheet

Set wsSGL = ActiveWorkbook.Sheets("SGL")
Set wsBPO = ActiveWorkbook.Sheets("BPO")
Set wsTest = ActiveWorkbook.Sheets("Test")

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

'Sheets("SGL").Activate

For Each ce In wsSGL.Range("AK5:AK" & Cells(Rows.Count, 1).End(xlUp).Row)
    If ce.Value = "x" Then
        ce.EntireRow.Copy Destination:=wsTest.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        ce.Value = "ok"
    End If
Next ce

'Sheets("BPO").Activate

For Each ce In wsBPO.Range("AK5:AK" & Cells(Rows.Count, 1).End(xlUp).Row)
    If ce.Value = "x" Then
        ce.EntireRow.Copy Destination:=wsTest.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        ce.Value = "ok"
    End If
Next ce

Application.ScreenUpdating = False
Application.Calculation = xlCalculationAutomatic

End Sub

 

[Pauline10]

Zot,

I just tried, it's much better, thank you very much ! The speed is not a problem anymore
I didn't know about the applications screen updates and calculation, next time I will make sure to use them.
Same for the sheet references...

 

[Zot]

Zot,

I just tried, it's much better, thank you very much ! The speed is not a problem anymore
I didn't know about the applications screen updates and calculation, next time I will make sure to use them.
Same for the sheet references...

Thanks for updating.
Every time there is change in worksheet, by default the sheet will be refreshed. Macro will pause to wait for refresh to be completed before continuing. You do not require that until everything is done. Same for the calculation (if there is formula in the sheet).

By defining sheet name, range (as you did), the code will not be resolving the object every time it comes across object the code is calling since it has been resolved by defining it. This will help execution speed. This is what I know

 

[Pauline10]

Ok I understand better now : you just need to define the object once and at the beginning... which indeed must be better for speed... and which I find makes it also easier to read... Thank you

I don't you want to ask too much of you but do you have any clue on what I could do for the two other problems ?

After having resolved the speed problem, I tackled my 2 other objectives : instead of copying the entire line, to only copy cells from columns A to D and F to K + copying in column A (of "TEST") the name of the sheet from which the data was copied. Unfortunately neither of my codes worked...

With the code below, the cells are pasted like asked, but only the data related to the first "x" is pasted in "TEST", not the other ones and I don't understand why ? The code is the same as the one copying the entire line, I feel like the only difference is the selection of a range. So why does the code work for the line and not for the selection ?

'Sheets("BPO").Activate

For Each ce In wsBPO.Range("AK5:AK" & Cells(Rows.Count, 1).End(xlUp).Row)

If ce.Value = "x" Then

Dim range1 As Range, range2 As Range, multiplerange As Range

Set range1 = Range("A" & ce.Row & ":D" & ce.Row)

Set range2 = Range("F" & ce.Row & ":K" & ce.Row)

Set multiplerange = Union(range1, range2)

multiplerange.Copy Destination:=Sheets("Test").Cells(Rows.Count, 1).End(xlUp).Offset(1, 1)

ce.Value = "ok"

End If

Next ce

And regarding the code to copy in column A (of "TEST") the name of the sheet from which the data was copied, I get an error, and again, I can't think of any other way of doing it :

'Sheets("BPO").Activate

For Each ce In wsBPO.Range("AK5:AK" & Cells(Rows.Count, 1).End(xlUp).Row)

If ce.Value = "x" Then

ce.EntireRow.Copy Destination:=wsTest.Cells(Rows.Count, 1).End(xlUp).Offset(1, 1)

ce.Value = "ok"

wsTest.Range("A" & wsTest.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)).Value = "BPO"

End If

Next ce

Here I thought I was asking, as a loop, to go in TEST, go at the last non empty cell in column A, + 1 line below, and to input "BPO". Therefore I expected the value "BPO" to be inputted in column A and for each line pasted from the sheet BPO.

But the code bugged and indicated that the copy area and paste area aren't the same size :

Maybe I'm involuntarily asking to paste the line in the area where I want to input the value "BPO" ?

 

[Zot]

In this line
ce.EntireRow.Copy Destination:=wsTest.Cells(Rows.Count, 1).End(xlUp).Offset(1, 1)

you copy entire row then you want to paste on wsTest.Cells(Rows.Count, 1).End(xlUp).Offset(1, 1)

which means (say row 10 for example) you wanted to paste on Range("A10").Offset(1,1) (which is Range("B11"))

It is not possible because now you copy from column A to the end but to paste on column B to the end. It will not fit having 1 cell excess

 

[Pauline10]

Thank you Zot ?