VBA to select and copy rows to new sheet based on a formula

[Anandpersad]

Hi All,
I am looking for a vba which will do the following:
Daily I get a list with data. The numbers of rows differs daily. From 10.000 rows to 18.000 rows.
I am looking for the following:
· VBA to check the dates in column AO and date in columns AP. If date in column AO > AP, select row and copy row to a Sheet called “date”. If there are more than one row, all have to be selected and copied to sheet “Date”
· VBA to check the amounts. Amounts are in column AA and column X. If the difference between AA and X (AA-X) is less than zero, select row and copy to sheet “Amount”. If there are more than one row, all have to be selected and copied to sheet “Amount”

Hoping someone can help me out here.


Thanks and Regards,

Anand

 

[Anandpersad]

Please please can someone help me?

 

[j_unsuitable]

Hey,

there probably is a faster way of doing it, but you could give this a try

Sub devideRows()
Dim LastRow As Long
Dim LRowDest As Long
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
For i = 2 To LastRow
If Cells(i, "AA").Value - Cells(i, "X").Value < 0 Then
    LRowDest = Worksheets("Amount").Cells(Rows.Count, "A").End(xlUp).Row
    Rows(i).EntireRow.Copy _
    Destination:=Worksheets("Amount").Range("A" & LRowDest + 1)
End If
If Cells(i, "AO").Value > Cells(i, "AP").Value Then
    LRowDest = Worksheets("Date").Cells(Rows.Count, "A").End(xlUp).Row
    Rows(i).EntireRow.Copy _
    Destination:=Worksheets("Date").Range("A" & LRowDest + 1)
End If
Next
Application.ScreenUpdating = True
End Sub

Julian

 

[Anandpersad]

Hi Julian,

Thank you very very much. This will save me lots of time.

Anand.