Excel VBA(非常慢)如果满足条件则将整行移动到底部

Question

只是寻找有关如何加速 VBA 查询之一的指导(如果满足条件，则将整行移至底部)

这就是到目前为止，它可以工作，但它真的很慢(只有大约 400 行的工作表需要大约 5 分钟才能运行)

Sub Running_Sort()

Application.ScreenUpdating = False

Dim i As Integer
Dim lr As Long

lrow = Range("D" & Rows.Count).End(xlUp).Row

For i = lrow To 6 Step -1
    If Cells(i, 15).Value = "Survey" Then
        Range(Cells(i, 4), Cells(i, 15)).Cut
        Sheets("Running").Range("D" & Rows.Count).End(3)(2).Insert
    End If
Next

Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

我已经关闭了屏幕更新，并且也从复制整行更改为仅复制我需要的列，但它们并没有产生太大的区别。

抱歉，如果我听起来很白痴，我是自学的，并且每天仍在学习，所以如果我犯了一个公然的错误或错过了一些明显的错误，请随时指导我:)

Answer 1

插入 通常是一个缓慢的操作，因为 Excel 必须检查所有数据并为每个移动的单元格重新分配地址。为了使此代码运行得更快，您需要将其重写为数组操作而不是工作表操作。

您可以快速从工作表中获取值，例如 MyArray = MySheet.Range("A1:Z50")，然后从数组粘贴回工作表，例如 MySheet.Range("A1:Z50") = MyArray.

我将这样做:

Sub Running_Sort()

    Application.ScreenUpdating = False
    
    Dim i As Long
    Dim lr As Long
    
    With Sheets("Running")
        lrow = .Range("D" & .Rows.Count).End(xlUp).Row
        
        'Save the Worksheet Area as a Range
        Dim TableRange As Range
        Set TableRange = .Range(.Cells(6, 4), .Cells(lrow, 15))
        
        'Grab all values from the Worksheet into a 2D Array of size (1 To Rows.Count, 1 to Columns.Count)
        Dim ValArray() As Variant
        ValArray = TableRange.Value
    End With
    
    For i = UBound(ValArray) To LBound(ValArray) Step -1
        'column 15 is now 12 because the array starts counting columns from 1 instead of 4
        '(15 - 4 + 1) = 12
        If ValArray(i, 12) = "Survey" Then ArrayRowShift ValArray, i, UBound(ValArray)
    Next

    TableRange.Value = ValArray

    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub


Sub ArrayRowShift(ByRef Arr As Variant, RowIndex As Long, MoveTo As Long)
    'For 2D arrays, takes an array row, moves it to the specified index, returns the shifted array
    If RowIndex = MoveTo Then Exit Sub
    Dim tmpRow() As Variant
    ReDim tmpRow(LBound(Arr, 2) To UBound(Arr, 2))
    For j = LBound(Arr, 2) To UBound(Arr, 2)
        tmpRow(j) = Arr(RowIndex, j)
    Next j
    If RowIndex < MoveTo Then
        For i = RowIndex + 1 To MoveTo
            For j = LBound(Arr, 2) To UBound(Arr, 2)
                Arr(i - 1, j) = Arr(i, j)
            Next j
        Next i
    Else
        For i = RowIndex To MoveTo + 1 Step -1
            For j = LBound(Arr, 2) To UBound(Arr, 2)
                Arr(i, j) = Arr(i - 1, j)
            Next j
        Next i
    End If
    For j = LBound(Arr, 2) To UBound(Arr, 2)
        Arr(MoveTo, j) = tmpRow(j)
    Next j
End Sub

ArrayRowShift 是我为之前的答案 here 编写的函数。将二维数组的行移动到新位置。