Comparing and realigning rows

[SS]

I would like to compare two columns.

I want to look at say Cell B2 and Cell E2.

If B2<E2, I want to shift D2 and E2 down one line and do a
series of formatting changes.

If B2>E2, I want to shift A2 and B2 down one line and do a
series of formatting changes.

If B2=E2 nothing should happen.

My code goes a bit crazy and begins shift cells down all
over the place and says there are no equivalents (and
there should be more equivalents then differences).

I want to take columns that look like this:
PM 023 PM 024
PM 045 PM 045
PR 015 PM 046

And make them look like this:
PM 023
PM 024
PM 045 PM 045
PM 046
PR 015





Here's what I have so far. It first looks at A and D to
see if they are different, then at B and E.



Count = 1
Do While Count < 200
Count = Count + 1

If ActiveSheet.Cells(Count, 1).Value =
ActiveSheet.Cells(Count, 4).Value Then
ActiveSheet.Cells(Count, 3).Value = ""
ElseIf ActiveSheet.Cells(Count, 1).Value >
ActiveSheet.Cells(Count, 4).Value Then
ActiveSheet.Range(Cells(Count, 1), Cells(Count,
2)).Insert Shift:=xlDown
ElseIf ActiveSheet.Cells(Count, 1).Value <
ActiveSheet.Cells(Count, 4).Value Then
ActiveSheet.Range(Cells(Count, 4), Cells(Count,
5)).Insert Shift:=xlDown
End If

If ActiveSheet.Cells(Count, 2).Value =
ActiveSheet.Cells(Count, 5).Value Then
If ActiveSheet.Cells(Count, 1).Value =
ActiveSheet.Cells(Count, 4).Value Then
ActiveSheet.Cells(Count, 3).Value = ""
End If
ElseIf ActiveSheet.Cells(Count, 2).Value <
ActiveSheet.Cells(Count, 5).Value Then
If ActiveSheet.Cells(Count, 1).Value =
ActiveSheet.Cells(Count, 4).Value Then
ActiveSheet.Range(Cells(Count, 4), Cells
(Count, 5)).Insert Shift:=xlDown
End If
ElseIf ActiveSheet.Cells(Count, 2).Value >
ActiveSheet.Cells(Count, 5).Value Then
If ActiveSheet.Cells(Count, 1).Value =
ActiveSheet.Cells(Count, 4).Value Then
ActiveSheet.Range(Cells(Count, 1), Cells
(Count, 2)).Insert Shift:=xlDown
End If
End If


If ActiveSheet.Cells(Count, 5).Value = "" Then
ActiveSheet.Cells(Count, 3).Value = "<--"
ActiveSheet.Range(Cells(Count, 1), Cells
(Count, 2)).Interior.ColorIndex = 35
ElseIf ActiveSheet.Cells(Count, 2).Value = "" Then
ActiveSheet.Cells(Count, 3).Value = "-->"
ActiveSheet.Range(Cells(Count, 4), Cells
(Count, 5)).Font.Strikethrough = True
End If

If ActiveSheet.Cells(Count, 1).Value = "" Then
If ActiveSheet.Cells(Count, 4).Value = "" Then
ActiveSheet.Range(Cells(Count, 1), Cells
(Count, 5)).Delete Shift:=xlUp
End If
End If
Loop

 

[Jean-Yves]

Hi,

Instead, work from bottom to top.
Regards,
Jean-Yves