ExcelVBA（非常慢）如果滿足條件，則將整行移動到底部

只是尋找有關如何加速我的 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

我關閉了螢屏更新，也從復制整行更改為只復制我需要的列，但它們沒有太大區別。

對不起，如果我聽起來很愚蠢，我是自學的并且每天仍在學習所以如果我犯了一個明顯的錯誤或遺漏了一些明顯的東西，請隨時向我學習:)

uj5u.com熱心網友回復：

Insert通常是一個緩慢的操作，因為 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 是我在此處為上一個答案撰寫的函式。將二維陣列的行移動到新位置。

uj5u.com熱心網友回復：

一種快速的通用方法是對表格進行排序而不是剪切/粘貼。

步驟是

• 將（臨時）公式添加到其他未使用的列中，根據需要對資料進行排序。
  在這種情況下，我建議=ROW() IF(RC[-1]="Survey",2000000,0)
• 根據此公式值對表格進行
  排序 排序可以使用
  • Excels 排序功能（手動或使用代碼）
  • 動態陣列公式SORT（同樣，手動或使用代碼）
  • 您選擇的編碼排序演算法
• 洗掉公式

您可以手動執行此操作，也可以根據需要對其進行編碼。

例如，這是一個使用動態陣列公式的 SubSORT
它假定

• 表格右側沒有資料
• 有沒有公式中的表中。（如果有，他們將被他們的價值觀所淹沒）
• 沒有參考表格的公式。（如果有，他們可能會也可能不會在 Sub 運行后參考正確的資料）

此代碼在 50,000 行上的測驗運行時間 <2 秒

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

uj5u.com熱心網友回復：

你可以試試這個，我已經發表了評論是有原因的。關于您的方法的一個警告是，如果您剪切的單元格包含公式，則可能會破壞“正在運行”作業表中的資料。

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

標籤：擅长 vba if 语句

上一篇：根據同一行中的值提取單個值（熊貓）

下一篇：Excel是否回傳預期結果