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

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.

A fast general approach would be Sort the table rather than Cut/Paste.

Steps would be

• Add a (temporary) formula to an otherwise unused column, that orders the data as you wish.
  In this case I'd suggest =ROW()+IF(RC[-1]="Survey",2000000,0)
• Sort the table based on this formula value
  Sort can be done with
  • Excels Sort functionality (manually or with code)
  • The Dynamic Array formula SORT (again, manually or with code)
  • A coded sort algorithm of your choice
• Remove the formula

You could do this manually, or code it, as you see fit.

As an example, here's a Sub that uses the Dynamic Array formula SORT
It assumes

• there is no data to the right of the table
• there are no formula in the table. (If there are, they will be overwitten with their values)
• there are no formula that refer to the table. (If there are, they may or may not end up refering to the correct data after the Sub is run)

A test run of this code on 50,000 rows ran in <2s

Sub MoveBySortTable()
    Dim ws As Worksheet
    Dim rTable As Range
    Dim Reordered As Variant
    
    Dim TableTopLeftCell As Range
    Dim TableTopRightCell As Range
    Dim KeyWord As String
    
    KeyWord = "Survey"
    
    Set ws = ActiveSheet ' or specify the required sheet
    
    ' set up parameters to define the table range
    Set TableTopLeftCell = ws.Cells(6, 4)  'D6
    Set TableTopRightCell = ws.Cells(TableTopLeftCell.Row, ws.Columns.Count).End(xlToLeft)
    ' or
    'Set TableTopLeftCell = ws.Cells(6, 15)
    
    ' Get reference to table range, plus one column
    Set rTable = ws.Range(TableTopRightCell, ws.Cells(ws.Rows.Count, TableTopLeftCell.Column).End(xlUp))
    Set rTable = rTable.Resize(, rTable.Columns.Count + 1)
    
    ' Add a formula to sort by
    rTable.Columns(rTable.Columns.Count).Formula2R1C1 = "=ROW()+IF(RC[-1]=""" & KeyWord & """,2000000,0)"

    ' Sort the table
    Reordered = ws.Evaluate("=SORT(" & rTable.Address & "," & rTable.Columns.Count & ")")
    
    ' Place sorted data onto sheet
    rTable.Value2 = Reordered
    
    ' Clear the formula
    rTable.Columns(rTable.Columns.Count).ClearContents
End Sub

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