简化我的代码以进行约 350,000 行查找。

Question

我有一个约 350,000 行数据的列表，我需要对其进行排序并将结果粘贴到新的 WS 上。前 12 列是权重，后 12 列是定性值。我需要在前 12 行中搜索值 2530 下的权重，同时还具有相应的定性值 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

简化我的代码以进行约 350,000 行查找。

Simplify my code for ~350,000 row look up.

vba

copy

worksheet

paste