I have written the following macro (some portions borrowed) and the
first two (2) subs run fine and move all of their data to their
respective sheets, but the the third (3rd) only does half the lines,
then if you run it again, half of what is left, and a third time
through completes. I have beat my head against the wall in an attempt
to figure out why 2/3's of it works wonderful and the last 1/3 is not
working? Any ideas? (Thanks in advance)
================================================== ================

Option Explicit
Sub CopyRows1()
Dim rng As Range
Dim cl As Range
Dim str As String

Set rng = ActiveSheet.Range("a2:a6500") 'Range to search (used
range)
str = "X" 'What to look for
For Each cl In rng 'Check each cell

If cl.Text = str Then
'If cell contains the correct value copy it to next empty
row on sheet 2 & delete the row sheet 1
cl.EntireRow.Copy Destination:=Sheet2.Cells(Rows.Count,
1).End(xlUp).Offset(1, 0)
cl.EntireRow.Delete
End If
Next cl
'Run ["Sheet1.CopyRows2"]
End Sub
-----------------------------------------------------------------------------------------------------------------
Sub CopyRows2()
Dim rng As Range
Dim cl As Range
Dim str As String

Set rng = ActiveSheet.Range("a2:a6500") 'Range/Column to search
str = "Y" 'What to look for
For Each cl In rng 'Check each cell

If cl.Text = str Then
'If cell contains the correct value copy it to next empty
row on sheet 3 & delete the row sheet 1
cl.EntireRow.Copy Destination:=Sheet3.Cells(Rows.Count,
1).End(xlUp).Offset(1, 0)
cl.EntireRow.Delete
End If
Next cl
'Run ["Sheet1.CopyRows3"]
End Sub
-----------------------------------------------------------------------------------------------------------
Sub CopyRows3()
Dim rng As Range
Dim cl As Range
Dim str As String

Set rng = ActiveSheet.Range("a2:a50") 'Range/Column to search
str = "A" 'What to look for
For Each cl In rng 'Check each cell

If cl.Text = str Then
'If cell contains the correct value copy it to next empty
row on sheet 4 & delete the row sheet 1
cl.EntireRow.Copy Destination:=Sheet4.Cells(Rows.Count,
1).End(xlUp).Offset(1, 0)
cl.EntireRow.Delete
End If
Next cl
'Run ["Sheet1.CopyRows4"]
End Sub
================================================== =============