move from sheet1 to sheet2 if criteria is met

[Guest]

I need VBA code that will move a row of data from Sheet1 to Sheet2 based on a
match to criteria. The criteria cell currently has the following formula in
it:
=IF(P11>=1000,500,P11)
If this formula is true the procedure must remove the row from Sheet1 and
plac it in the next available row on Sheet2.
The procedure must loop until there is no more data matching the criteria on
sheet1.
I really need this help ASAP.

 

[Norman Jones]

Hi P,

For a more sophisticated alternative to Excel's Data
Form, see John Walkenbach's Enhanced DataForm,
which may be downloaded, free of charge, at:

http://j-walk.com/ss/dataform/index.htm

Fopr additional customisation, the code password is
available for a nominal sum.

 

[Norman Jones]

Hi P,

Try something like:

'================>>
Public Sub Tester()
Dim WB As Workbook
Dim SH As Worksheet
Dim destSH As Worksheet
Dim Rng As Range
Dim destRng As Range
Dim rCell As Range
Dim delRng As Range
Dim iRow As Long, jRow As Long
Dim CalcMode As Long
Const myVal As Long = 1000

Set WB = Workbooks("MyBokk.xls") '<<===== CHANGE

With WB
Set SH = .Sheets("Sheet1") '<<===== CHANGE
Set destSH = .Sheets("Sheet2") '<<==== CHANGE
End With

iRow = LastRow(SH, SH.Columns("A:A"))
Set Rng = SH.Range("A1:A" & iRow) '<<===== CHANGE

On Error GoTo XIT
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

For Each rCell In Rng.Cells
If rCell.Offset(0, 15).Value > myVal Then
If delRng Is Nothing Then
Set delRng = rCell
Else
Set delRng = Union(rCell, delRng)
End If
End If
Next rCell

If Not delRng Is Nothing Then
With destSH
jRow = LastRow(destSH, .Columns("A:A"))
Set destRng = .Range("A" & jRow + 1)
End With

With delRng.EntireRow
.Copy Destination:=destRng
.EntireRow.Delete
End With
End If

XIT:
With Application
.Calculation = CalcMode
.ScreenUpdating = True
End With
End Sub
'--------------->

Function LastRow(SH As Worksheet, _
Optional Rng As Range)
If Rng Is Nothing Then
Set Rng = SH.Cells
End If

On Error Resume Next
LastRow = Rng.Find(What:="*", _
After:=Rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
'<<==========

 

[Norman Jones]

Hi P,

Apologies - thiis was intended as a response to
another thread!