Copy & paste is stalling my macro

Question

I have a macro which takes data from one workbook, filters the fairly large page down to the data i require only, then copies values to a dummy sheet in my main workbook where non required rows are removed and columns are sorted into an order more suitable for my application. my problem is it takes an age to complete and quite often crashes. I am still new to VBA and have tried my best to slicken the code but am not getting anywhere. I have used F8 to define the areas which slow it up and they are the filtering, copy/paste and cut/insert. If anyone can help it would be greatly appreciated. Thanks in advance

M

`Sub NEW_OPS_AWAY_REPORT()


MsgBox ("BOTTLENECKS AND OPS AWAY SPREADSHEET & GEARSHOP WORK TO LIST FROM REPORT CENTRE MUST BE OPEN FOR THIS REPORT TO FUNCTION CORRECTLY")

Application.Calculation = xlCalculationManual

Application.ScreenUpdating = False

Application.DisplayStatusBar = False

Application.EnableEvents = False

ActiveSheet.DisplayPageBreaks = False

Windows("DAILY BOTTLENECKS ANALYSIS & OPS AWAY.xlsm").Activate
Sheets("WIP by Op").Visible = True
Sheets("WIP by Op").Range("$A$1:$Q$47290").AutoFilter Field:=1, Criteria1:="TS1H124*", Operator:=xlFilterValues
Windows("PRESS QUENCH FIRST OFF DATABASE.xlsm").Activate
Sheets("REPORT DATA TRANSFER").Visible = True
Sheets("REPORT DATA TRANSFER").Select
Cells.Select
Selection.ClearContents
Windows("DAILY BOTTLENECKS ANALYSIS & OPS AWAY.xlsm").Activate
Sheets("WIP by Op").Select
Cells.Select
Selection.Copy
Windows("PRESS QUENCH FIRST OFF DATABASE.xlsm").Activate
ActiveSheet.Paste
Range("F:F,G:G,H:H,M:M,P:P,Q:Q").Select
Range("Q1").Activate
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Columns("A:K").Select
Columns("A:K").EntireColumn.AutoFit
Columns("J:J").Select
Selection.Cut
Columns("A:A").Select
Selection.Insert Shift:=xlToRight
Columns("I:I").Select
Selection.Cut
Columns("B:B").Select
Selection.Insert Shift:=xlToRight
Columns("J:J").Select
Selection.Cut
Columns("C:C").Select
Selection.Insert Shift:=xlToRight
Columns("G:G").Select
Selection.Cut
Columns("D:D").Select
Selection.Insert Shift:=xlToRight
Columns("H:H").Select
Selection.Cut
Columns("E:E").Select
Selection.Insert Shift:=xlToRight
Columns("H:H").Select
Selection.Cut
Columns("F:F").Select
Selection.Insert Shift:=xlToRight
Columns("J:J").Select
Selection.Cut
Columns("I:I").Select
Selection.Insert Shift:=xlToRight
Application.Calculation = xlCalculationAutomatic
Range("A1:K1").Select
Selection.AutoFilter
ActiveWorkbook.Worksheets("REPORT DATA TRANSFER").AutoFilter.Sort.SortFields. _
    Clear
ActiveWorkbook.Worksheets("REPORT DATA TRANSFER").AutoFilter.Sort.SortFields. _
    Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, _
    DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("REPORT DATA TRANSFER").AutoFilter.Sort
    .header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
Sheets("Ops Away Report").Select
Columns("A:K").Select
Selection.ClearContents
Sheets("REPORT DATA TRANSFER").Select
Columns("A:K").Select
Selection.Copy
Sheets("Ops Away Report").Select
Range("A1").Select
ActiveSheet.Paste
Range("A:A,E:E,F:F,I:I,J:J").Select
Range("J1").Activate
Application.CutCopyMode = False
With Selection
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlBottom
    .WrapText = False
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
    .MergeCells = False
End With
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
Range("A1:L1").Select
Selection.AutoFilter
Columns("B:B").Select

Sheets("REPORT DATA TRANSFER").Visible = False



Dim lastRow As Long

lastRow = Range("A2").End(xlDown).Row

For Each Cell In Range("A2:Q" & lastRow) ''change range accordingly
If Cell.Row Mod 2 = 1 Then ''highlights row 2,4,6 etc|= 0 highlights 1,3,5
    Cell.Interior.ColorIndex = 34 ''color to preference
Else
    Cell.Interior.ColorIndex = xlNone ''color to preference or remove
End If
Next Cell



Columns("D:D").EntireColumn.AutoFit
Columns("H:H").ColumnWidth = 7.43
Range("A1:O1").AutoFilter

Application.Calculation = xlCalculationAutomatic

Application.ScreenUpdating = True

Application.DisplayStatusBar = True

Application.EnableEvents = True

ActiveSheet.DisplayPageBreaks = True

End Sub`

Start by using `Application.ScreenUpdating = False` at the beginning of your macro (and reset it to `True` and the end). Then read up on [how to avoid using `Select` in your macro](https://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba#10717999) — cybernetic.nomad, May 11 '18 at 14:18
I believe the `.Select` `.Activate` is probably contributing to some of the slowness. `Application.ScreenUpdating = False` is already present in the code. There's a lot happening in this code. Is there any particular block of it that is causing it to run long? — JNevill, May 11 '18 at 14:32
In particular, this section causes the first long waiting period when single blocking through the code.'Sheets("WIP by Op").Range("$A$1:$Q$47290").AutoFilter Field:=1, Criteria1:="TS1H124*", Operator:=xlFilterValues Windows("PRESS QUENCH FIRST OFF DATABASE.xlsm").Activate Sheets("REPORT DATA TRANSFER").Visible = True Sheets("REPORT DATA TRANSFER").Select Cells.Select Selection.ClearContents Windows("DAILY BOTTLENECKS ANALYSIS & OPS AWAY.xlsm").Activate Sheets("WIP by Op").Select Cells.Select Selection.Copy Windows("PRESS QUENCH FIRST OFF DATABASE.xlsm").Activate ActiveSheet.Paste' — Emark, May 11 '18 at 14:51
If you are only copying values then ditch copy/paste entirely and just assign directly to the `.Value` property of the target range. — John Coleman, May 11 '18 at 14:53

score 0 · Answer 1 · answered May 11 '18 at 16:24

Looking through your code there's a lot of extra code in there.
For instance, adding a border around each cell can be done with Selection.Borders.LineStyle = xlContinuous

This code starts with the two workbooks closed. Update the Const variables with the correct file paths.
You'll probably need to disable events still, depending on what code's in the other workbooks.

Public Sub New_Ops_Away_Report()

    Const BottleNecks_Path As String = "C:\Somefolder\DAILY BOTTLENECKS ANALYSIS & OPS AWAY.xlsm"
    Const OpsAway_Path  As String = "C:\Somefolder\PRESS QUENCH FIRST OFF DATABASE.xlsm"

    Dim wrkBk_BottleNeck As Workbook
    Dim wrkbk_OpsAway As Workbook

    Dim rWIP_LastCell As Range
    Dim rReport_LastCell As Range

    Set wrkBk_BottleNeck = Workbooks.Open(Filename:=BottleNecks_Path)
    Set wrkbk_OpsAway = Workbooks.Open(Filename:=OpsAway_Path)

    'Clear the contents of the named sheet.
    wrkbk_OpsAway.Worksheets("REPORT DATA TRANSFER").Cells.ClearContents

    With wrkBk_BottleNeck
        'Find the last populated cell on the worksheet.
        Set rWIP_LastCell = LastCell(.Worksheets("WIP by OP"))
        With .Worksheets("WIP by OP")
            With .Range(.Cells(1, 1), rWIP_LastCell)
                'Add a filter from A1 to the last populated cell.
                .AutoFilter Field:=1, Criteria1:="TS1H124*", Operator:=xlFilterValues
                .Copy Destination:=wrkbk_OpsAway.Worksheets("REPORT DATA TRANSFER").Range("A1")
            End With
        End With
    End With

    With wrkbk_OpsAway.Worksheets("REPORT DATA TRANSFER")

        ''''''''''''''''''''''''
        'This bit is confusing in your code.
        'I think it's trying to do as below, but I've commented out the last line
        'as it appears to clear the data you just copied over.
        .Range("F:F,G:G,H:H,M:M,P:P,Q:Q").Delete Shift:=xlToLeft
        .Columns("A:K").EntireColumn.AutoFit
        '.Columns("A:J").EntireColumn.ClearContents
        ''''''''''''''''''''''''

        'Find last populated cell on the worksheet.
        Set rReport_LastCell = LastCell(wrkbk_OpsAway.Worksheets("REPORT DATA TRANSFER"))

        With .Sort
            .SortFields.Clear
            .SortFields.Add Key:=Range("A1").Resize(rReport_LastCell.Row), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SetRange wrkbk_OpsAway.Worksheets("REPORT DATA TRANSFER").Range("A1").Resize(rReport_LastCell.Row, rReport_LastCell.Column)
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With

        .Range("A1").Resize(rReport_LastCell.Row, rReport_LastCell.Column).Borders.LineStyle = xlContinuous

    End With

End Sub

Public Function LastCell(wrkSht As Worksheet, Optional Col As Long = 0) As Range

    Dim lLastCol As Long, lLastRow As Long

    On Error Resume Next

    With wrkSht
        lLastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
        lLastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row

        If lLastCol = 0 Then lLastCol = 1
        If lLastRow = 0 Then lLastRow = 1

        Set LastCell = wrkSht.Cells(lLastRow, lLastCol)
    End With
    On Error GoTo 0

End Function

Much appreciated. I'm still having problems though. i would normally run the macro from a button in the 'ops away' worksheet. the code you kindly gave me looks to open the worksheet that will receive the data and also the one that will send it. i have tried the code in a blank WB with the other WB's closed and it doesn't complete and results in me having to force excel to close. i have tried some amendments but with my low skill level I am not getting anywhere. Thank you in advance for any further help that can be given. — Emark, May 15 '18 at 08:29
If the code is in the `OpsAway_Path` workbook I think the easiest change will be to this line: `Set wrkbk_OpsAway = Workbooks.Open(Filename:=OpsAway_Path)` to `Set wrkbk_OpsAway =ThisWorkbook`. `ThisWorkbook` always refers to the file that contains the code. — Darren Bartrup-Cook, May 15 '18 at 08:42

Copy & paste is stalling my macro

1 Answers1