Вырезать и вставлять строки, почему так медленно, пытаясь ускорить производительность

Question

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

Я успешно написал код макроса, чтобы это произошло, однако он использует команду выбораи очень медленно. Я использовал тот же код ранее в другом проекте, и он был намного быстрее, почти мгновенно, единственное отличие, о котором я могу думать, это то, что я выбирал ВСЮ строку. В этом конкретном случае я только хочу переместить данные в столбцах B - N. Столбцы O - Y имеют фиксированные входы и не могут быть перемещены.

Ниже приведен рабочий код для перемещения диапазона вверх.

Sub MoveUp()
Application.ScreenUpdating = False
ActiveSheet.Unprotect 'Unprotects The Sheet
    If Not Intersect(ActiveCell, Range("B12:F98")) Is Nothing Then 'Makes sure you are within the correct range, cannot move top row up

    Range("B" & ActiveCell.Row & ":" & "N" & ActiveCell.Row).Select 'Selects only area you want to move
    Selection.Rows(Selection.Rows.Count + 1).Insert Shift:=xlDown
    Selection.Rows(1).Offset(-1).Cut Selection.Rows(Selection.Rows.Count + 1)
    Selection.Rows(1).Offset(-1).Delete Shift:=xlUp
    Selection.Offset(-1).Select 'This keeps the cell you moved selected so you can keep moving it without having to reselect

    Else
        MsgBox "You Can't Move That Row Up"
    End If

    Call ResetRanges 'Resets the named ranges
    Call ProtectWorkSheet 'Protects The Sheet
Application.ScreenUpdating = True
End Sub

Я написал альтернативный макрос , не используя select , пытаясь использовать определенные диапазоны и смещения для осуществления сдвига, но он все еще был таким же медленным, как и приведенный выше код. Я что-то упустил?

Sub MoveUpRangeMethod()
Application.ScreenUpdating = False

activerow = ActiveCell.Row
endon = activerow - 1
Set rng = Range("B" & activerow & ":" & "N" & activerow)
Set rng2 = Range("B" & activerow - 1 & ":" & "N" & activerow - 1)
rng3 = ("F" & endon)

rng.Cut
rng2.Insert Shift:=xlDown
Range(rng3).Activate

Application.ScreenUpdating = True
End Sub

Обновление:

Я написал макрос другим способом, и он все еще работает медленно. Я думаю, что есть что-то еще за кулисами, вызывающее замедление. Это вполне может быть из-за какого-то плохого кода, который у меня есть в другом месте. Ниже приведен новый код, который я пробовал, опять же, он быстро работает в новом листе, но изо всех сил в книге, где он мне нужен.

Sub ShiftCellsDown()
Dim ws As Worksheet: Set ws = ThisWorkbook.ActiveSheet
Application.ScreenUpdating = False
Application.Calculation = xlManual
Application.DisplayAlerts = False

    ws.Range("B" & ActiveCell.Row - 1 & ":" & "N" & ActiveCell.Row - 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    ws.Range("B" & ActiveCell.Row - 1 & ":" & "N" & ActiveCell.Row - 1).Value = ws.Range("B" & ActiveCell.Row + 1 & ":" & "N" & ActiveCell.Row + 1).Value
    ws.Range("B" & ActiveCell.Row + 1 & ":" & "N" & ActiveCell.Row + 1).Delete Shift:=xlUp
    ws.Range(("F" & ActiveCell.Row - 1)).Activate

Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

Answer 1

Как насчет следующего, я просто немного упростил ваш код и добавил несколько строк для повышения производительности:

Sub MoveUpRangeMethod()
Dim ws As Worksheet: Set ws = ThisWorkbook.ActiveSheet
Application.ScreenUpdating = False
Application.Calculation = xlManual
Application.DisplayAlerts = False

    ws.Range("B" & ActiveCell.Row & ":" & "N" & ActiveCell.Row).Cut
    ws.Range("B" & ActiveCell.Row - 1 & ":" & "N" & ActiveCell.Row - 1).Insert Shift:=xlDown
    ws.Range("F" & ActiveCell.Row - 1).Activate

Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

ОБНОВЛЕНИЕ:

Может помочь следующее обновление,вместо «Вырезать и вставить диапазоны» он присваивает значения массивам, а затем передает их значения в нужные ячейки, тем самым, надеясь, ускоряет процесс: