Excel VBA runs "painfully" slow to copy filtered and paste

Cakz Primz · Oct 10, 2022

Dear All,

I am using Office 365, and I need to filter, copy visible only from one book to another workbook.
The data source is around 35,000 rows, from column A to AK.

With the code below, it runs "painfully" slow to copy the filtered range, visible cell only and paste it onto another workbook.
I need your expertise suggestions to find the solution.

VBA Code:

Sub CopyPaste()
    With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
    .DisplayStatusBar = False
  
    Windows("RFM Log.xlsx").Activate
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim twb As Workbook
    Dim ws As Worksheet
    Dim tws As Worksheet
    Set wb = Workbooks("RFM.xlsx") 'source workbook
    Set ws = wb.Sheets("RFM - Register") 'source worksheet
    Set twb = Workbooks("PO.xlsb") 'target workbook
    Set tws = twb.Sheets("RFM Reg") 'target worksheet     
    Dim lRow As Long
    lRow = Cells(Rows.Count, 1).End(xlUp).Row

    With ws
    .Range("A2:AK" & lRow).AutoFilter Field:=4, Criteria1:="1", Operator:=xlFilterValues
    .Range("A3:B" & lRow).SpecialCells(xlCellTypeVisible).Copy
    With tws
    .Range("A3").PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    End With
    End With
    
    Set rng = tws.Range("D3:D50000")
    With ws
    .Range("D3:D50000").SpecialCells(xlCellTypeVisible).Copy
    With tws
    .Range("C3").PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    End With
    End With
    
    With ws
    .Range("H3:J50000").SpecialCells(xlCellTypeVisible).Copy
    With tws
    .Range("D3").PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    End With
    End With
    
    With ws
    .Range("N3:Q50000").SpecialCells(xlCellTypeVisible).Copy
    With tws
    .Range("G3").PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    End With
    End With
    
    With ws
    .Range("S3:AG50000").SpecialCells(xlCellTypeVisible).Copy
    With tws
    .Range("K3").PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    End With
    End With

    With ws
    .Range("AK3:AK50000").SpecialCells(xlCellTypeVisible).Copy
    With tws
    .Range("Z3").PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    End With
    End With
        
    wb.Close savechanges:=False
    
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
    .DisplayStatusBar = True
    End With
End Sub

I do really hope that someone could help me.
Thank you very much, really appreciate for your time.

Cakz Primz · Oct 11, 2022

The source file is RFM.xlsx
The target file is PO.xlsb (where macro should reside in)

Thank you

Cakz Primz · Oct 11, 2022

igold said:
Name of workbook please...

Dear igold,

The source file is RFM.xlsx
And the target file is PO.xlsb

Thank you very much

igold · Oct 11, 2022

With your source data in your Post #5- I ran your code and then my code. Below my posted code, is a mini sheet of the results from your code and the results from my code. I did not try to replicate your colorful formatting, I only concentrated on getting the correct data on the page. This code should run much quicker since it is using arrays and doing all the work in memory. I also ignored the headers.

VBA Code:

Sub CopyPaste()
    
    Dim arrS, arrD, rng As Range, i As Long, ct As Long, lRow As Long
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .DisplayStatusBar = False
    End With
  
    Windows("RFM Log.xlsx").Activate
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim twb As Workbook
    Dim ws As Worksheet
    Dim tws As Worksheet
    Set wb = Workbooks("RFM.xlsx") 'source workbook
    Set ws = wb.Sheets("RFM - Register") 'source worksheet
    Set twb = Workbooks("PO.xlsb") 'target workbook
    Set tws = twb.Sheets("RFM Reg") 'target worksheet
    
    lRow = Cells(Rows.Count, 1).End(xlUp).Row
    ct = 1
    With ws
        arrS = .Range("A3:AK" & lRow)
        ReDim arrD(1 To UBound(arrS), 1 To 2)
        For i = 1 To UBound(arrS)
            If arrS(i, 4) = 1 Then
                arrD(ct, 1) = arrS(i, 1)
                arrD(ct, 2) = arrS(i, 2)
                ct = ct + 1
            End If
        Next
    End With
    
    With tws
        .Range("A3").Resize(UBound(arrD, 1), UBound(arrD, 2)) = arrD
        ct = 1
        ReDim arrD(1 To UBound(arrS), 1 To 1)
        For i = 1 To UBound(arrS)
            If arrS(i, 4) = 1 Then
                arrD(ct, 1) = arrS(i, 4)
                ct = ct + 1
            End If
        Next
        .Range("C3").Resize(UBound(arrD, 1), UBound(arrD, 2)) = arrD
        ct = 1
        ReDim arrD(1 To UBound(arrS), 1 To 3)
        For i = 1 To UBound(arrS)
            If arrS(i, 4) = 1 Then
                arrD(ct, 1) = arrS(i, 8)
                arrD(ct, 2) = arrS(i, 9)
                arrD(ct, 3) = arrS(i, 10)
                ct = ct + 1
            End If
        Next
        .Range("D3").Resize(UBound(arrD, 1), UBound(arrD, 2)) = arrD
        ct = 1
        ReDim arrD(1 To UBound(arrS), 1 To 4)
        For i = 1 To UBound(arrS)
            If arrS(i, 4) = 1 Then
                arrD(ct, 1) = arrS(i, 14)
                arrD(ct, 2) = arrS(i, 15)
                arrD(ct, 3) = arrS(i, 16)
                arrD(ct, 4) = arrS(i, 17)
                ct = ct + 1
            End If
        Next
        .Range("G3").Resize(UBound(arrD, 1), UBound(arrD, 2)) = arrD
        ct = 1
        ReDim arrD(1 To UBound(arrS), 1 To 15)
        For i = 1 To UBound(arrS)
            If arrS(i, 4) = 1 Then
                arrD(ct, 1) = arrS(i, 19)
                arrD(ct, 2) = arrS(i, 20)
                arrD(ct, 3) = arrS(i, 21)
                arrD(ct, 4) = arrS(i, 22)
                arrD(ct, 5) = arrS(i, 23)
                arrD(ct, 6) = arrS(i, 24)
                arrD(ct, 7) = arrS(i, 25)
                arrD(ct, 8) = arrS(i, 26)
                arrD(ct, 9) = arrS(i, 27)
                arrD(ct, 10) = arrS(i, 28)
                arrD(ct, 11) = arrS(i, 29)
                arrD(ct, 12) = arrS(i, 30)
                arrD(ct, 13) = arrS(i, 31)
                arrD(ct, 14) = arrS(i, 32)
                arrD(ct, 15) = arrS(i, 33)
                ct = ct + 1
            End If
        Next
        .Range("K3").Resize(UBound(arrD, 1), UBound(arrD, 2)) = arrD
        ct = 1
        ReDim arrD(1 To UBound(arrS), 1 To 1)
        For i = 1 To UBound(arrS)
            If arrS(i, 4) = 1 Then
                arrD(ct, 1) = arrS(i, 37)
                ct = ct + 1
            End If
        Next
        .Range("Z3").Resize(UBound(arrD, 1), UBound(arrD, 2)) = arrD
    End With
        
    wb.Close savechanges:=False
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .DisplayStatusBar = True
    End With
    
End Sub

PO.xlsm

A

B

C

D

E

F

G

H

I

J

K

L

M

N

O

P

Q

R

S

T

U

V

W

X

Y

Z

AA

1

2

YOUR CODE

3

2076

1

SITE

WINA

VINYL TAPE 2" 3M 471 LIGHT BLUE

TAUFIK ISMAIL

#N/A

COMM

1/3/2020

MAKSIMA

N/A

#N/A

N/A

#N/A

43855

CLOSED

N/A

COMPLETED

4

2077

1

SITE

LIEVAN

OPTIC DISTRIBUTION PANEL 12 CORE

YUDHI PRATAMA

#N/A

BSMG

1/4/2020

HALCOM

N/A

#N/A

11642383

1309838

31.01.2020

43875

CLOSED

N/A

COMPLETED

5

2078

1

SUBC

TETI

HYTERA HT RADIO NON IS TYPE

YUDHI PRATAMA

#N/A

BSMG

1/4/2020

SUBCONT

N/A

#N/A

N/A

#N/A

43902

CLOSED

N/A

COMPLETED

6

2079

1

SITE

CASH ADVANCE

STAMP FOR SUBCONTRACTING

DHITA ROCHADI

CONST

1/3/2020

LOCAL SUPPLIER

N/A

#N/A

N/A

#N/A

43902

CLOSED

N/A

COMPLETED

7

2080

1

JAKARTA

RENI

STICKER HSSE AWARENESS & TEP GATEWAY

IMMANUEL SUEKEN

#N/A

HSSE

1/5/2020

REVO PRINT INDONESIA

N/A

#N/A

11639554

1308091

21.01.2020

43867

CLOSED

N/A

COMPLETED

8

9

10

11

MY CODE

12

2076

1

SITE

WINA

VINYL TAPE 2" 3M 471 LIGHT BLUE

TAUFIK ISMAIL

#N/A

COMM

1/3/2020

MAKSIMA

N/A

#N/A

N/A

#N/A

43855

CLOSED

N/A

COMPLETED

13

2077

1

SITE

LIEVAN

OPTIC DISTRIBUTION PANEL 12 CORE

YUDHI PRATAMA

#N/A

BSMG

1/4/2020

HALCOM

N/A

#N/A

11642383

1309838

31.01.2020

43875

CLOSED

N/A

COMPLETED

14

2078

1

SUBC

TETI

HYTERA HT RADIO NON IS TYPE

YUDHI PRATAMA

#N/A

BSMG

1/4/2020

SUBCONT

N/A

#N/A

N/A

#N/A

43902

CLOSED

N/A

COMPLETED

15

2079

1

SITE

CASH ADVANCE

STAMP FOR SUBCONTRACTING

DHITA ROCHADI

CONST

1/3/2020

LOCAL SUPPLIER

N/A

#N/A

N/A

#N/A

43902

CLOSED

N/A

COMPLETED

16

2080

1

JAKARTA

RENI

STICKER HSSE AWARENESS & TEP GATEWAY

IMMANUEL SUEKEN

#N/A

HSSE

1/5/2020

REVO PRINT INDONESIA

N/A

#N/A

11639554

1308091

21.01.2020

43867

CLOSED

N/A

COMPLETED

17

18

19

20

Results

Cakz Primz · Oct 11, 2022

With your source data in your Post #5- I ran your code and then my code. Below my posted code, is a mini sheet of the results from your code and the results from my code. I did not try to replicate your colorful formatting, I only concentrated on getting the correct data on the page. This code should run much quicker since it is using arrays and doing all the work in memory. I also ignored the headers.

igold said:

VBA Code:

Sub CopyPaste()
   
    Dim arrS, arrD, rng As Range, i As Long, ct As Long, lRow As Long
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .DisplayStatusBar = False
    End With
 
    Windows("RFM Log.xlsx").Activate
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim twb As Workbook
    Dim ws As Worksheet
    Dim tws As Worksheet
    Set wb = Workbooks("RFM.xlsx") 'source workbook
    Set ws = wb.Sheets("RFM - Register") 'source worksheet
    Set twb = Workbooks("PO.xlsb") 'target workbook
    Set tws = twb.Sheets("RFM Reg") 'target worksheet
   
    lRow = Cells(Rows.Count, 1).End(xlUp).Row
    ct = 1
    With ws
        arrS = .Range("A3:AK" & lRow)
        ReDim arrD(1 To UBound(arrS), 1 To 2)
        For i = 1 To UBound(arrS)
            If arrS(i, 4) = 1 Then
                arrD(ct, 1) = arrS(i, 1)
                arrD(ct, 2) = arrS(i, 2)
                ct = ct + 1
            End If
        Next
    End With
   
    With tws
        .Range("A3").Resize(UBound(arrD, 1), UBound(arrD, 2)) = arrD
        ct = 1
        ReDim arrD(1 To UBound(arrS), 1 To 1)
        For i = 1 To UBound(arrS)
            If arrS(i, 4) = 1 Then
                arrD(ct, 1) = arrS(i, 4)
                ct = ct + 1
            End If
        Next
        .Range("C3").Resize(UBound(arrD, 1), UBound(arrD, 2)) = arrD
        ct = 1
        ReDim arrD(1 To UBound(arrS), 1 To 3)
        For i = 1 To UBound(arrS)
            If arrS(i, 4) = 1 Then
                arrD(ct, 1) = arrS(i, 8)
                arrD(ct, 2) = arrS(i, 9)
                arrD(ct, 3) = arrS(i, 10)
                ct = ct + 1
            End If
        Next
        .Range("D3").Resize(UBound(arrD, 1), UBound(arrD, 2)) = arrD
        ct = 1
        ReDim arrD(1 To UBound(arrS), 1 To 4)
        For i = 1 To UBound(arrS)
            If arrS(i, 4) = 1 Then
                arrD(ct, 1) = arrS(i, 14)
                arrD(ct, 2) = arrS(i, 15)
                arrD(ct, 3) = arrS(i, 16)
                arrD(ct, 4) = arrS(i, 17)
                ct = ct + 1
            End If
        Next
        .Range("G3").Resize(UBound(arrD, 1), UBound(arrD, 2)) = arrD
        ct = 1
        ReDim arrD(1 To UBound(arrS), 1 To 15)
        For i = 1 To UBound(arrS)
            If arrS(i, 4) = 1 Then
                arrD(ct, 1) = arrS(i, 19)
                arrD(ct, 2) = arrS(i, 20)
                arrD(ct, 3) = arrS(i, 21)
                arrD(ct, 4) = arrS(i, 22)
                arrD(ct, 5) = arrS(i, 23)
                arrD(ct, 6) = arrS(i, 24)
                arrD(ct, 7) = arrS(i, 25)
                arrD(ct, 8) = arrS(i, 26)
                arrD(ct, 9) = arrS(i, 27)
                arrD(ct, 10) = arrS(i, 28)
                arrD(ct, 11) = arrS(i, 29)
                arrD(ct, 12) = arrS(i, 30)
                arrD(ct, 13) = arrS(i, 31)
                arrD(ct, 14) = arrS(i, 32)
                arrD(ct, 15) = arrS(i, 33)
                ct = ct + 1
            End If
        Next
        .Range("K3").Resize(UBound(arrD, 1), UBound(arrD, 2)) = arrD
        ct = 1
        ReDim arrD(1 To UBound(arrS), 1 To 1)
        For i = 1 To UBound(arrS)
            If arrS(i, 4) = 1 Then
                arrD(ct, 1) = arrS(i, 37)
                ct = ct + 1
            End If
        Next
        .Range("Z3").Resize(UBound(arrD, 1), UBound(arrD, 2)) = arrD
    End With
       
    wb.Close savechanges:=False
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .DisplayStatusBar = True
    End With
   
End Sub

PO.xlsm

A

B

C

D

E

F

G

H

I

J

K

L

M

N

O

P

Q

R

S

T

U

V

W

X

Y

Z

AA

1

2

YOUR CODE

3

2076

1

SITE

WINA

VINYL TAPE 2" 3M 471 LIGHT BLUE

TAUFIK ISMAIL

#N/A

COMM

1/3/2020

MAKSIMA

N/A

#N/A

N/A

#N/A

43855

CLOSED

N/A

COMPLETED

4

2077

1

SITE

LIEVAN

OPTIC DISTRIBUTION PANEL 12 CORE

YUDHI PRATAMA

#N/A

BSMG

1/4/2020

HALCOM

N/A

#N/A

11642383

1309838

31.01.2020

43875

CLOSED

N/A

COMPLETED

5

2078

1

SUBC

TETI

HYTERA HT RADIO NON IS TYPE

YUDHI PRATAMA

#N/A

BSMG

1/4/2020

SUBCONT

N/A

#N/A

N/A

#N/A

43902

CLOSED

N/A

COMPLETED

6

2079

1

SITE

CASH ADVANCE

STAMP FOR SUBCONTRACTING

DHITA ROCHADI

CONST

1/3/2020

LOCAL SUPPLIER

N/A

#N/A

N/A

#N/A

43902

CLOSED

N/A

COMPLETED

7

2080

1

JAKARTA

RENI

STICKER HSSE AWARENESS & TEP GATEWAY

IMMANUEL SUEKEN

#N/A

HSSE

1/5/2020

REVO PRINT INDONESIA

N/A

#N/A

11639554

1308091

21.01.2020

43867

CLOSED

N/A

COMPLETED

8

9

10

11

MY CODE

12

2076

1

SITE

WINA

VINYL TAPE 2" 3M 471 LIGHT BLUE

TAUFIK ISMAIL

#N/A

COMM

1/3/2020

MAKSIMA

N/A

#N/A

N/A

#N/A

43855

CLOSED

N/A

COMPLETED

13

2077

1

SITE

LIEVAN

OPTIC DISTRIBUTION PANEL 12 CORE

YUDHI PRATAMA

#N/A

BSMG

1/4/2020

HALCOM

N/A

#N/A

11642383

1309838

31.01.2020

43875

CLOSED

N/A

COMPLETED

14

2078

1

SUBC

TETI

HYTERA HT RADIO NON IS TYPE

YUDHI PRATAMA

#N/A

BSMG

1/4/2020

SUBCONT

N/A

#N/A

N/A

#N/A

43902

CLOSED

N/A

COMPLETED

15

2079

1

SITE

CASH ADVANCE

STAMP FOR SUBCONTRACTING

DHITA ROCHADI

CONST

1/3/2020

LOCAL SUPPLIER

N/A

#N/A

N/A

#N/A

43902

CLOSED

N/A

COMPLETED

16

2080

1

JAKARTA

RENI

STICKER HSSE AWARENESS & TEP GATEWAY

IMMANUEL SUEKEN

#N/A

HSSE

1/5/2020

REVO PRINT INDONESIA

N/A

#N/A

11639554

1308091

21.01.2020

43867

CLOSED

N/A

COMPLETED

17

18

19

20

Results

Dear igold,

Thanks a lot for your kindness and helping hands.
I will try the code and let you know the result very soon.

Again, thank you very much

Cakz Primz · Oct 11, 2022

With your source data in your Post #5- I ran your code and then my code. Below my posted code, is a mini sheet of the results from your code and the results from my code. I did not try to replicate your colorful formatting, I only concentrated on getting the correct data on the page. This code should run much quicker since it is using arrays and doing all the work in memory. I also ignored the headers.

Cakz Primz said:
Dear igold,

Thanks a lot for your kindness and helping hands.
I will try the code and let you know the result very soon.

Again, thank you very much

Dear igold,

I run the code, and it gave me an error in this line number 4, as below:

VBA Code:

    lRow = Cells(Rows.Count, 1).End(xlUp).Row
    ct = 1
    With ws
        arrS = .Range("A3:AK" & lRow)

Thank you

Cakz Primz · Oct 11, 2022

Cakz Primz said:
With your source data in your Post #5- I ran your code and then my code. Below my posted code, is a mini sheet of the results from your code and the results from my code. I did not try to replicate your colorful formatting, I only concentrated on getting the correct data on the page. This code should run much quicker since it is using arrays and doing all the work in memory. I also ignored the headers.

Dear igold,

I run the code, and it gave me an error in this line number 4, as below:

VBA Code:

lRow = Cells(Rows.Count, 1).End(xlUp).Row ct = 1 With ws arrS = .Range("A3:AK" & lRow)

Thank you

Cakz Primz · Oct 11, 2022

I run the code from destination workbook, then it activate the source book but it stop on the line of code as the picture, attached.

Thank you very much

Alex Blakenburg · Oct 11, 2022

Try adding "ws." to the line as I have done below:

Rich (BB code):

lRow = ws.Cells(Rows.Count, 1).End(xlUp).Row

Excel VBA runs "painfully" slow to copy filtered and paste

Cakz Primz

Board Regular

Cakz Primz

Board Regular

Excel Facts

Cakz Primz

Board Regular

igold

Well-known Member

Cakz Primz

Board Regular

Cakz Primz

Board Regular

Cakz Primz

Board Regular

Attachments

Cakz Primz

Board Regular

Alex Blakenburg

MrExcel MVP

Similar threads

Forum statistics

Share this page

Excel VBA runs "painfully" slow to copy filtered and paste

Board Regular

Board Regular

Excel Facts

Board Regular

Well-known Member

Board Regular

Board Regular

Board Regular

Attachments

Board Regular

MrExcel MVP

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock