Search code examples
vbacopypasteworksheet

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


I have a list of ~350,000 lines of data that I need to sort through and paste results onto a new WS. The first 12 columns are weights and the second 12 columns are qualitative values. I need to search for weights in the first 12 lines under a value of 2530 while also having a corresponding qualitative value of 0.

The weights begin in column C and have a corresponding qualitative value in the O column (+12 columns). this pattern is repeated for all 12 columns of weights and subsequent qualitative values.

I am new to VBA and my code has been pieced together from various sources. It seems to take forever to run and I am unsure as to if it is faulty code or just a massive data set for excel to handle. Any help is greatly appreciated. Thank you!

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

Solution

  • may be the following will lead you to some affordable speed:

    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