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
================================================== =============

Deleting rows in a range that you are traversing can be problematic. Things
sometimes get missed. What you wnat to do is to craverse the entier range
creating a single large range to be copied at the end... (this code will also
be a bit faster as it only does a single copy and a single delete)

Sub CopyRows3()
Dim rng As Range
Dim cl As Range
Dim rngAll 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 rngAll is nothing then
set rngall = cl
else
set rngall = union(cl, rngAll)
end if
End If
Next cl
if not rngall is nothing then
rngall.copy Destination:=Sheet4.Cells(Rows.Count,
1).End(xlUp).Offset(1, 0)
rngall.entirerow.delete
end if
'Run ["Sheet1.CopyRows4"]
End Sub

--
HTH...

Jim Thomlinson


"RONZANDER" wrote:

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
================================================== =============

It works beautifully and thank you for the assistance. I would like to
understand the differences better however, and the "union" was
something new to me. Could you take a minute and perhaps add some
notes to the code to explain how it funtions and where each
calculation occurs? If not, I do understand and still very much
appreciate the new code.

Ron
================================================
===============================================

On Sep 29, 12:06*pm, Jim Thomlinson <James_Thomlin...@owfg-Re-Move-
This-.com wrote:
Deleting rows in a range that you are traversing can be problematic. Things
sometimes get missed. What you wnat to do is to craverse the entier range
creating a single large range to be copied at the end... (this code will also
be a bit faster as it only does a single copy and a single delete)

Sub CopyRows3()
* * Dim rng * * * *As Range
* * Dim cl * * * * As Range
* * Dim rngAll 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 rngAll is nothing then
* * * * * * * *set rngall = cl
* * * * * * else
* * * * * * * *set rngall = union(cl, rngAll)
* * * * * * end if
* * * * End If
* * Next cl
* * if not rngall is nothing then
* * * rngall.copy Destination:=Sheet4.Cells(Rows.Count,
1).End(xlUp).Offset(1, 0)
* * * rngall.entirerow.delete
* * end if
* * 'Run ["Sheet1.CopyRows4"]
End Sub

--
HTH...

Jim Thomlinson



"RONZANDER" wrote:
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
================================================== =============- Hide quoted text -

- Show quoted text -