Excel VBA - ускорение копирования макроса

Question

Я использую этот макрос, который отлично работает, хотя и очень медленно.Есть ли способ ускорить его (возможно, с массивами), чтобы вся операция выполнялась только один раз?

Что мой код делает, так это то, что он фильтрует таблицу Excel, а затем извлекает только определенные столбцы и вставляет их вдругой лист (в другом порядке).

Set lo_b1 = x_bf1.ListObjects(1)
s_date = CLng(ThisWorkbook.Names("in_fre_m").RefersToRange(1, 1))
s_des = ThisWorkbook.Names("dr_no").RefersToRange(1, 1)
s_code = ThisWorkbook.Names("dr_co").RefersToRange(1, 1)
lastrow_d = lo_dr.Range.Columns(1).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
Set pasterange1 = x_drill.Range("C" & lastrow_d)

    With lo_b1.Range
    .AutoFilter Field:=13, Criteria1:=s_code
    .AutoFilter Field:=1, Criteria1:="<=" & s_date
    End With

lastrow_s = lo_b1.Range.Columns(1).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

If lastrow_s > 7 Then
    Set copyrange1 = x_bf1.Range("D8:D" & lastrow_s) 'Date
    Set copyrange2 = copyrange1.Offset(0, 1)  'Description
    Set copyrange3 = copyrange1.Offset(0, 16)  'Calculation
    Set copyrange5 = copyrange1.Offset(0, 5)  'Classification
    Set copyrange6 = copyrange1.Offset(0, 6)  'Notes
    Set copyrange7 = copyrange1.Offset(0, 11) '§
    Set copyrange8 = copyrange1.Offset(0, 12) 'Code
    Set copyrange9 = copyrange1.Offset(0, 20) 'Statutory
    Set copyrange10 = copyrange1.Offset(0, 14) 'Ref


    copyrange10.SpecialCells(xlCellTypeVisible).Copy 'Ref
    pasterange1.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone

    copyrange1.SpecialCells(xlCellTypeVisible).Copy 'Date
    pasterange1.Offset(0, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone

    copyrange5.SpecialCells(xlCellTypeVisible).Copy 'Account Name
    pasterange1.Offset(0, 2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone

    copyrange2.SpecialCells(xlCellTypeVisible).Copy 'Notes
    pasterange1.Offset(0, 3).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone

    copyrange8.SpecialCells(xlCellTypeVisible).Copy 'Code
    pasterange1.Offset(0, 4).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone

    copyrange7.SpecialCells(xlCellTypeVisible).Copy '§
    pasterange1.Offset(0, 5).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone

    copyrange3.SpecialCells(xlCellTypeVisible).Copy 'Calculation
    pasterange1.Offset(0, 6).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone

    copyrange9.SpecialCells(xlCellTypeVisible).Copy 'Statutory
    pasterange1.Offset(0, 7).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone

    copyrange6.SpecialCells(xlCellTypeVisible).Copy 'Notes
    pasterange1.Offset(0, 8).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone

    Set copyrange1 = Nothing
    Set copyrange2 = Nothing
    Set copyrange3 = Nothing
    Set copyrange4 = Nothing
    Set copyrange5 = Nothing
    Set copyrange6 = Nothing
    Set copyrange7 = Nothing
    Set copyrange8 = Nothing
    Set copyrange9 = Nothing
    Set copyrange10 = Nothing
    End If

Answer 1

Чтобы добавить к комментариям об обновлении экрана, событиях и расчетах, попробуйте изменить

copyrange10.SpecialCells(xlCellTypeVisible).Copy 'Ref
pasterange1.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone

до

pasterange1.Value=copyrange1.SpecialCells(xlCellTypeVisible).Value

По моему опыту, это намного быстрее, чем копирование и вставка (и это также предотвращает проблемы с другим приложением, использующим буфер обмена)