move contents down and replace contents and loop

[loss1003]

I’m looking for vba code to move down the cell contents in an active cell (column A) down one cell and move the cell contents underneath the active cell up one, by criteria, and repeat the loop until the first empty row in Column A
<?xml:namespace prefix = o ns = "urn:schemas-microsoft-comfficeffice" /><o> </o>
Column A Column D<o></o>
Safety Vendor 5
General Vendor 3
Property Vendor 2<o></o>
Casualty Vendor 2
Taxi Vendor 5<o></o>
Products Vendor 10<o></o>
<o> </o><o> </o>
When the following criteria is meet in column D
>4
The active cell contents in column A drop down one cell and be replaced with the cell contents below. <o></o>
<o> </o>
If I ran the code the table above would now look: <o></o>
<o> </o>
Column A Column D<o></o>
General Vendor 3 (Moved Up One from orginial)
Safety Vendor 5 (Moved Down One from orginial)
Property Vendor 2
Casualty Vendor 2<o></o>
Products Vendor 10 (Moved Up One from orginial)
Taxi Vendor 5 (Moved Down One)

and would continue all the way down the columns until the first empty row.

Appreciate any assistance you can provide!
<o></o>
<o> </o>
Hope you can help<o></o>

 

[BobUmlas]

Sub Swapper()
For i = 1 To Range("A60000").End(xlUp).Row
If Cells(i, 4).Value > 4 Then
Rows(i).Cut
Rows(i + 2).Insert
i = i + 1
End If
Next
End Sub

 

[loss1003]

Sub Swapper()
For i = 1 To Range("A60000").End(xlUp).Row
If Cells(i, 4).Value > 4 Then
Rows(i).Cut
Rows(i + 2).Insert
i = i + 1
End If
Next
End Sub

Thanks the code works. How can I amend the code to continually loop until the following criteria is meet in each row.

If Cells(I, 4).Value > 2 And Cells(I, 3).Value = 1 Then

loop until?

For I = 1 To Range("A411").End(xlUp).Row
Do
If Cells(I, 4).Value > 2 And Cells(I, 3).Value = 1 Then
Rows(I).Cut
Rows(I + 2).Insert
I = I + 1
End If
Loop Until I = Cells(I, 4).Value > 2

Next

End Sub

 

[BobUmlas]

Sorry - I don't understand. Can you explain in English when you want the code to stop? And why cell A411 instead of A60000?

 

[loss1003]

I would like the code you provided for Range A2:A411 to continually/repeatedly loop <?xml:namespace prefix = o ns = "urn:schemas-microsoft-comfficeffice" /><o></o>
<o> </o>
Until all the rows meet these criteria:<o></o>
<o> </o>
If Cells(I, 3).Value = 1 And Cells(I, 4).Value > 2<o></o>

 

[BobUmlas]

This does what you asked, but might run forever!<?xml:namespace prefix = o ns = "urn:schemas-microsoft-comfficeffice" /><o></o>
Sub Swapper()<o></o>
Do Until Cells(I, 3).Value = 1 And Cells(I, 4).Value > 2 <o></o>
For i = 1 To Range("A60000").End(xlUp).Row
If Cells(i, 4).Value > 4 Then
Rows(i).Cut
Rows(i + 2).Insert
i = i + 1
End If
Next<o></o>
Wend
End Sub<o></o>

 

[loss1003]

This does what you asked, but might run forever!<?xml:namespace prefix = o ns = "urn:schemas-microsoft-comfficeffice" /><o></o>
Sub Swapper()<o></o>
Do Until Cells(I, 3).Value = 1 And Cells(I, 4).Value > 2<o></o>
For i = 1 To Range("A60000").End(xlUp).Row
If Cells(i, 4).Value > 4 Then
Rows(i).Cut
Rows(i + 2).Insert
i = i + 1
End If
Next<o></o>
Wend
End Sub<o></o>

Getting a compile error: Wend without While

Thanks,

 

[BobUmlas]

sorry - change Wend to Loop

 

[loss1003]

Now I'm getting a application error run time error

 

[BobUmlas]

OK, I looked carefully at your request and now I know why it's not working -- I don't understand the question! You say:
...continually loop until the following criteria is meet in each row...
That doesn't make sense. If the criteria is not met in the row, then it will never be met and it will loop forever. Nothing in the code or requirements changes the values in columns 3 or 4.
So maybe you could better explain what you really want to do...?