簡化我的代碼〜350,000行查找。

Question

我有一個約350,000行數據的列表，我需要排序並將結果粘貼到新的WS上。前12列是權重，第12列是定性值。我需要在值爲2530的前12行中搜索權重，同時也具有相應的定性值0.

權重從C列開始，並且在O列中具有對應的定性值（+12列）。對於所有12列權重和隨後的定性值重複該模式。

我是VBA的新手，我的代碼已經從各種來源拼湊在一起。這似乎需要永遠運行，我不確定是否它是錯誤的代碼或只是一個龐大的數據集爲Excel處理。任何幫助是極大的讚賞。謝謝！

Sub CopyRowsWithNumbersInB() 
Dim X As Long 
Dim LastRow As Long 
Dim Source As Worksheet 
Dim Destination As Worksheet 
Dim RowsWithNumbers As Range 
Set Source = Worksheets("Sheet1") 
Set Destination = Worksheets("Sheet2") 

With Source 
LastRow = .Cells(.Rows.Count, "C").End(xlUp).Row 
For X = 1 To LastRow 
If _ 
    (IsNumeric(.Cells(X, "C").Value) And .Cells(X, "C").Value < "2530" And IsNumeric(.Cells(X, "O").Value) And .Cells(X, "O").Value > "0") Or (_ 
    IsNumeric(.Cells(X, "D").Value) And .Cells(X, "D").Value < "2530" And IsNumeric(.Cells(X, "P").Value) And .Cells(X, "P").Value > "0") Or (_ 
    IsNumeric(.Cells(X, "E").Value) And .Cells(X, "E").Value < "2530" And IsNumeric(.Cells(X, "Q").Value) And .Cells(X, "Q").Value > "0") Or (_ 
    IsNumeric(.Cells(X, "F").Value) And .Cells(X, "F").Value < "2530" And IsNumeric(.Cells(X, "R").Value) And .Cells(X, "R").Value > "0") Or (_ 
    IsNumeric(.Cells(X, "G").Value) And .Cells(X, "G").Value < "2530" And IsNumeric(.Cells(X, "S").Value) And .Cells(X, "S").Value > "0") Or (_ 
    IsNumeric(.Cells(X, "H").Value) And .Cells(X, "H").Value < "2530" And IsNumeric(.Cells(X, "T").Value) And .Cells(X, "T").Value > "0") Or (_ 
    IsNumeric(.Cells(X, "I").Value) And .Cells(X, "I").Value < "2530" And IsNumeric(.Cells(X, "U").Value) And .Cells(X, "U").Value > "0") Or (_ 
    IsNumeric(.Cells(X, "J").Value) And .Cells(X, "J").Value < "2530" And IsNumeric(.Cells(X, "V").Value) And .Cells(X, "V").Value > "0") Or (_ 
    IsNumeric(.Cells(X, "K").Value) And .Cells(X, "K").Value < "2530" And IsNumeric(.Cells(X, "W").Value) And .Cells(X, "W").Value > "0") Or (_ 
    IsNumeric(.Cells(X, "L").Value) And .Cells(X, "L").Value < "2530" And IsNumeric(.Cells(X, "X").Value) And .Cells(X, "X").Value > "0") Or (_ 
    IsNumeric(.Cells(X, "M").Value) And .Cells(X, "M").Value < "2530" And IsNumeric(.Cells(X, "Y").Value) And .Cells(X, "Y").Value > "0") Or (_ 
    IsNumeric(.Cells(X, "N").Value) And .Cells(X, "N").Value < "2530" And IsNumeric(.Cells(X, "Z").Value) And .Cells(X, "Z").Value > "0") Then 

    If RowsWithNumbers Is Nothing Then 
     Set RowsWithNumbers = .Cells(X, "C") 
     Else 
     Set RowsWithNumbers = Union(RowsWithNumbers, .Cells(X, "C")) 
    End If 
End If 
Next 
If Not RowsWithNumbers Is Nothing Then 
    RowsWithNumbers.EntireRow.Copy Destination.Range("A1") 
End If 
End With 
End Sub 

Answer 1

可能是下面就帶你到一些實惠速度：

Option Explicit 

Sub main() 
    Dim iColumn As Long 
    Dim RowsWithNumbers As Range 

    Application.ScreenUpdating = False 
    iColumn = 1 
    With ThisWorkbook.Worksheets("SheetData") '<--| reference your sheet name 
     With .Range("Z1", .cells(.Rows.Count, "C").End(xlUp)) '<--| reference its column C:Z range from row 1 (header) down to the last column C not empty row 
      Set RowsWithNumbers = .Offset(, .Columns.Count).Resize(1, 1) '<--| add a "dummy" cell to avoid 'If Not RowsWithNumbers Is Nothing' check (the "dummy" cell will be eventually removed) 
      Do 
       .AutoFilter Field:=iColumn, Criteria1:="<2530" '<--| filter 'iColumn' column with numbers < 2530 
       .AutoFilter Field:=iColumn + 12, Criteria1:=">0" '<--| filter 'iColumn+12' column with numbers >0 
       If Application.WorksheetFunction.Subtotal(103, .Resize(, 1)) > 1 Then Set RowsWithNumbers = Union(RowsWithNumbers, .Resize(.Rows.Count - 1, 1).Offset(1).SpecialCells(xlCellTypeVisible)) 
       iColumn = iColumn + 1 
      Loop While iColumn <= 12 
     End With 
     .AutoFilterMode = False '<--| remove autofilter 
     Set RowsWithNumbers = Intersect(RowsWithNumbers, .cells) '<--| remove "dummy" cell 
     If Not RowsWithNumbers Is Nothing Then Intersect(RowsWithNumbers.EntireRow, .cells).Copy Worksheets("Destination").Range("A1") 
    End With 
    Application.ScreenUpdating = True 
End Sub