code dosen't work

[ksnapp]

Here is what im hoping to accomplish:

I need a sub that will look down column E if it finds the word Steak i
will look in the cell to the right, if that value is less than or equa
(<=) to 1 then it will look in the same row column A and check to se
if there is anything there. If there is not (cell in column A i
empty) then it just delete the whole row and continues down column E.
If there is anything in column A then it copies it to the cell below i
and then deletes the offending row.

Simply put:

search column E, if a cell in E says "Steak" with a quantity of 1 o
less then it deletes the row, but not before moving any data in colum
A of that row so It is not destroyed.

Here is the code I have written, I can't figure out where the proble
is. When it runs it ends up with the active cell in column F
I tried checking all the offsets, but everytime I change something i
runs even stranger.


Sub steaks()

Dim N As String
Dim X As Single
Range("E2").Select
Do Until X = 5
If activecell.Value = "Steak" Then
activecell.Offset(0, 1).Select
If activecell.Value <= 1 Then
activecell.Offset(0, -4).Select
If activecell.Value <> "" Then
N = activecell.Value
activecell.Offset(1, 0).Value = N
activecell.Offset(-1, 4).Select
selection.EntireRow.Delete
activecell.Offset(1, 0).Select
Else
selection.EntireRow.Delete
activecell.Offset(1, 0).Select
End If
Else
activecell.Offset(1, 0).Select
End If
Else
activecell.Offset(1, 0).Select
End If

If activecell.Value = "" Then
X = X + 1
Else
X = 0
Loop
End Sub

Thank Yo

 

[Bob Phillips]

I haven't proved it to myself, but I would guess that the problem is caused
by all of the jumping about, activating different cells, and you are losing
track of your position. And when deleting rows, always work bottom up.

Try this version

Sub steaks()
Dim X As Single

For X = Cells(Rows.Count, "E").End(xlUp).Row To 1 Step -1
With Cells(X, "E")
If .Value = "Steak" Then
If .Offset(0, 1).Value <= 1 Then
If .Offset(0, -4).Value <> "" Then
.Offset(1, -4).Value = .Offset(0, -4).Value
End If
.EntireRow.Delete
End If
End If
End With
Next X
End Sub


--

HTH

Bob Phillips
... looking out across Poole Harbour to the Purbecks
(remove nothere from the email address if mailing direct)

 

[ksnapp]

THANK YOU works perfect and so much smaller than mine
again thank yo