Excel VBA (very slow) If condition is met then move entire row to the bottom-CodePudding

just looking for guidance on how I might speed up one of my VBA query's (if condition is met then move the entire row to the bottom)

This is what have so far and it works, but its really slow (sheet with only approx 400 rows takes approx 5 mins to run)

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

I've turned off screen updating and also changed from copying the entire row to just the columns that I need but they haven't made much of a difference.

Sorry if i sound idiotic, I'm self taught and still learning daily so feel free to school me if I've made a blatant error or missed something obvious:)

CodePudding user response：

You can try this, I have placed comment for reason. One warning about your method is that if the cells you cut contains formulas, it may ruin the data in the "Running" worksheet.

Sub Running_Sort()
    Debug.Print "Running_Sort() Started: " & Now

    Application.ScreenUpdating = False
    
    Dim i As Long, lCalcMode As Long
    Dim lRow As Long
    
    lCalcMode = Application.Calculation ' Stores original setting
    Application.Calculation = xlCalculationManual ' Pause auto calculating
    
    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
        DoEvents ' Typically solves Excel being halted for large amount of entries in loop
    Next
    Application.CutCopyMode = False
    
    Application.Calculation = lCalcMode ' Restores original setting
    
    Application.ScreenUpdating = True
    Debug.Print "Running_Sort() Finished: " & Now
End Sub

CodePudding user response：

Insert is a slow operation in general because Excel has to check all the data and reassign addresses to every moved cell. To make this code run faster, you'll want to rewrite it as an array operation and not a worksheet operation.

You can quickly grab values from a sheet like MyArray = MySheet.Range("A1:Z50") and then paste back from an array to a Worksheet like MySheet.Range("A1:Z50") = MyArray.

Here is how I would do that:

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 is the function I wrote for a previous answer here. To move rows of a 2D array into a new position.