Copy/Paste takes too long

[Redwolfx]

Hi Everyone, I've put together some VBA that works for what I need it to do, but the transfer of data takes about 5 minutes which is way too long.

Here's what I've got going on, I've got a button, in a workbook, it opens another workbook, filters the data, Copies it and pastes it into my workbook, then does a simple name change and refreshes a pivot table. The problem is that the source data can have upwards of 200K rows of data, when I try to copy and paste, it takes about 5 minutes to complete. Anyone have any suggestions how to clean this up to improve run time?

Thanks in advance.

Sub Button_Click()

Dim Chgdate As String
Dim Chgdate2 As String

x = Weekday(Date, vbSaturday)
Select Case x
    Case 1
        x = 2
    Case 2
        x = 3
    Case Else
    x = 1
End Select

Chgdate = Format(Date - x, "m-dd-yyyy")
Chgdate2 = Format(Date - x, "mm-dd-yy")

ChDir "F:\*****\*******\" & Chgdate
Workbooks.Open Filename:= _
        "F:\*****\*******\" & Chgdate & "\" & Chgdate2 & "_cr.xlsx"

Worksheets(Chgdate2 & "_cr").Select

ActiveSheet.Columns("$B:$L").AutoFilter Field:=4, Criteria1:= _
Array("ANAADJ", "ANABKY", "ANACHK", "ANAHMP", "ANAHOT", "ANAVIP", "ESCDOC", _
      "ESCHBS", "ESCKNT", "ESCMOD", "ESCREM", "FLDDEC", "FLDDF1", "FLDDF2", _
      "FLDDIS", "FLDEC1", "FLDEC2", "FLDNET", "FLDZDR", "HAZADD", "HAZAIR", _
      "HAZANA", "HAZBCO", "HAZDIS", "HAZFCO", "HAZFOR", "HAZHOT", "HAZLEG", _
      "HAZLOS", "HAZMOD", "HAZSAL", "HAZVAC", "HAZVIP", "HOTANA", "HOTLOS", _
      "IHZCHK", "IHZCK1", "IHZCK2", "INSAIR", "INSCHG", "INSCOR", "INSPHE", _
      "IRTATR", "ITXCHK", "ITXHOT", "ITXNEC", "LDINSP", "LOSACH", "LOSADJ", _
      "LOSAUT", "LOSC2P", "LOSC3P", "LOSCIP", "LOSCON", "LOSCOR", "LOSDSB", _
      "LOSFOL", "LOSNDA", "LOSWAV", "MI2PRM", "MIPAIR", "MIPFCL", "MIPFCO", _
      "MIPRES", "NEINFO", "PAYTAX", "PCH1HG", "PMIAIR", "PMIAPR", "PMICLM", _
      "PMICOR", "PMIFCL", "PMIHOT", "PMIRE1", "PMIREC", "PMIRES", "PMIRIN", _
      "PRTDEL", "PRTINS", "PRTTAX", "QBEEML", "QWRTAX", "REOADD", "REOCNX", _
      "RESINQ", "RESTXR", "TARALL", "TARDLQ", "TARDOC", "TAREXP", "TAXADD", _
      "TAXANA", "TAXBK1", "TAXCKR", "TAXCL1", "TAXCOR", "TAXEXP", "TAXFC1", _
      "TAXFCO", "TAXFOL", "TAXHOT", "TAXLOS", "TAXMOD", "TAXNEL", "TAXNET", _
      "TAXPLN", "TAXRDM", "TAXRE1", "TAXRE2", "TAXREO", "TAXRTN", "TAXSRL", _
      "TAXVIP", "TXBILL", "TXEXPT", "TXPRCL", "TXRFND", "WAVESC", "WAVINS", _
      "WAVPMI", "WEBTAX", "ZCMAIL", "ZCSCKR", "ZCSDOC", "ZCSFLD", "ZCSHOT", _
      "ZCSLP1", "ZCSND2", "ZCSNDA", "ZCSOUT", "ZCSPHE", "ZCSPIP", "ZCSRES"), _
      Operator:=xlFilterValues
      
    Columns("G:G").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
      
Worksheets(Chgdate2 & "_cr").Range("B1:L200000").Rows.SpecialCells(xlCellTypeVisible).Copy
    ActiveWindow.WindowState = xlMinimized
    Sheets("Company Task").Select
    Range("A1").Select
    ActiveSheet.Paste
    
    Sheets(1).Select
    Sheets(1).Name = Chgdate2
    
    ActiveSheet.PivotTables("PivotTable1").PivotCache.Refresh
    
End Sub

 

[par60056]

Are you sure it is in the Copy that it takes so long? I suspect that much of the time is dealing with what should be displayed as it applies the filters. Try turning off screen updating.

Application.ScreenUpdating = False

And remember to turn it back on

 

[Redwolfx]

Tested, unfortunately it doesn't appear that the screen updating being turned off did much of anything, Still took about 5 minutes to Copy/Paste. The filter actually works almost instantaneously when I step through, but the paste is where it gets caught up.

Another strange thing, when it pastes into my sheet, even though there are only about 8K lines with actual data, it seems to be putting 150K+ lines into the sheet.

I'm perplexed.

 

[par60056]

Are there formulas in what you are copying? Do you need them if you are just going to feed it to a pivot table? Might pasting values only help?

I have not tried using the SpecialCells so it may have something to do with that. But you say the copy is fine just pasting is slow.

So I'm perplexed too.

 

[Redwolfx]

So I've worked around it, sort of.

So it appears it is not the amount of data that was the problem, and not the filtering at its source anyway, but the actual copying of the filtered data from one workbook to the next.

So I copied the raw data from one workbook to the next, then filtered it, then copied to another sheet. Then deleted the original sheet (to minimize the size of the file).

I also made the adjustment to copy a smaller range by pulling the last cell instead of going to 200K all the time.

Still take about a minute, but loads better than the 5 it was taking before.

Sub Button_Click()
Dim Chgdate As String
Dim Chgdate2 As String
Dim Last As Range

x = Weekday(Date, vbSaturday)
Select Case x
    Case 1
        x = 2
    Case 2
        x = 3
    Case Else
    x = 1
End Select
Chgdate = Format(Date - x, "m-dd-yyyy")
Chgdate2 = Format(Date - x, "mm-dd-yy")
ChDir "F:\******\******\" & Chgdate
Workbooks.Open Filename:= _
        "F:\******\******\" & Chgdate & "\" & Chgdate2 & "_cr.xlsx"
    Cells.Select
    Application.CutCopyMode = False
    Selection.Copy
Windows("Department Manager Escrow Template.xlsm").Activate
Sheets("Data").Select
Range("A1").Select
ActiveSheet.Paste
ActiveSheet.Columns("$B:$L").AutoFilter Field:=4, Criteria1:= _
Array("ANAADJ", "ANABKY", "ANACHK", "ANAHMP", "ANAHOT", "ANAVIP", "ESCDOC", _
      "ESCHBS", "ESCKNT", "ESCMOD", "ESCREM", "FLDDEC", "FLDDF1", "FLDDF2", _
      "FLDDIS", "FLDEC1", "FLDEC2", "FLDNET", "FLDZDR", "HAZADD", "HAZAIR", _
      "HAZANA", "HAZBCO", "HAZDIS", "HAZFCO", "HAZFOR", "HAZHOT", "HAZLEG", _
      "HAZLOS", "HAZMOD", "HAZSAL", "HAZVAC", "HAZVIP", "HOTANA", "HOTLOS", _
      "IHZCHK", "IHZCK1", "IHZCK2", "INSAIR", "INSCHG", "INSCOR", "INSPHE", _
      "IRTATR", "ITXCHK", "ITXHOT", "ITXNEC", "LDINSP", "LOSACH", "LOSADJ", _
      "LOSAUT", "LOSC2P", "LOSC3P", "LOSCIP", "LOSCON", "LOSCOR", "LOSDSB", _
      "LOSFOL", "LOSNDA", "LOSWAV", "MI2PRM", "MIPAIR", "MIPFCL", "MIPFCO", _
      "MIPRES", "NEINFO", "PAYTAX", "PCH1HG", "PMIAIR", "PMIAPR", "PMICLM", _
      "PMICOR", "PMIFCL", "PMIHOT", "PMIRE1", "PMIREC", "PMIRES", "PMIRIN", _
      "PRTDEL", "PRTINS", "PRTTAX", "QBEEML", "QWRTAX", "REOADD", "REOCNX", _
      "RESINQ", "RESTXR", "TARALL", "TARDLQ", "TARDOC", "TAREXP", "TAXADD", _
      "TAXANA", "TAXBK1", "TAXCKR", "TAXCL1", "TAXCOR", "TAXEXP", "TAXFC1", _
      "TAXFCO", "TAXFOL", "TAXHOT", "TAXLOS", "TAXMOD", "TAXNEL", "TAXNET", _
      "TAXPLN", "TAXRDM", "TAXRE1", "TAXRE2", "TAXREO", "TAXRTN", "TAXSRL", _
      "TAXVIP", "TXBILL", "TXEXPT", "TXPRCL", "TXRFND", "WAVESC", "WAVINS", _
      "WAVPMI", "WEBTAX", "ZCMAIL", "ZCSCKR", "ZCSDOC", "ZCSFLD", "ZCSHOT", _
      "ZCSLP1", "ZCSND2", "ZCSNDA", "ZCSOUT", "ZCSPHE", "ZCSPIP", "ZCSRES"), _
      Operator:=xlFilterValues
      
    Columns("G:G").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
      
 Set Last = Worksheets("Data").Range("B1:L200000").Rows.SpecialCells(xlLastCell)
 Set Last = Range("B1", Last)
 Last.Rows.SpecialCells(xlCellTypeVisible).Copy
Sheets("Company Task").Select
Range("A1").Select
ActiveSheet.Paste
    
Sheets("Summary").Select
Sheets("Summary").Name = Chgdate2
Range("A1") = Chgdate
    
ActiveSheet.PivotTables("PivotTable1").PivotCache.Refresh
    Sheets("Data").Select
    Application.CutCopyMode = False
    ActiveWindow.SelectedSheets.Delete
    
    Sheets("Button Page").Select
    Application.CutCopyMode = False
    ActiveWindow.SelectedSheets.Delete
    
End Sub