Hi Howard,

Am Fri, 21 Feb 2014 01:16:31 -0800 (PST) schrieb L. Howard:

4000 rows in about 1 second!

a little bit faster. 10000 rows in 0.955 sec:

Sub MyScan3()
Dim LRow As Long
Dim myArr As Variant
Dim i As Long, j As Long

LRow = Cells(Rows.Count, 1).End(xlUp).Row
myArr = Range("A2:B" & LRow)
For i = LBound(myArr) To UBound(myArr)
If Left(myArr(i, 1), 1) < "P" Then
myArr(i - 1, 2) = myArr(i, 1)
myArr(i, 1) = ""
End If
Next

Range("A2:B" & LRow).ClearContents
j = 2
For i = LBound(myArr) To UBound(myArr)
If myArr(i, 1) < "" Then
Cells(j, 1) = myArr(i, 1)
Cells(j, 2) = myArr(i, 2)
j = j + 1
End If
Next
End Sub


Regards
Claus B.
--
Win XP PRof SP2 / Vista Ultimate SP2
Office 2003 SP2 /2007 Ultimate SP2