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
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