Help? Anyone see problem with this macro? Way to condense it?

R

RONZANDER

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

Jim Thomlinson

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 said:
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
===============================================================
Click to expand...
 
R

RONZANDER

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

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 said:
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)
==================================================================
Click to expand...
Option Explicit
Sub CopyRows1()
    Dim rng        As Range
    Dim cl         As Range
    Dim str        As String
Click to expand...
    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
Click to expand...
        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
Click to expand...
    Set rng = ActiveSheet.Range("a2:a6500") 'Range/Column to search
    str = "Y" 'What to look for
    For Each cl In rng 'Check each cell
Click to expand...
        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
Click to expand...
    Set rng = ActiveSheet.Range("a2:a50") 'Range/Column to search
    str = "A" 'What to look for
    For Each cl In rng 'Check each cell
Click to expand...
        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 -
Click to expand...

- Show quoted text -
Click to expand...
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Concatenate a row that is selected and include blank cells 11
Advanced Filter Error - I cannot spot my Error 3
Eliminate blanks while copy row and transpose 11
Append Worksheet name to each begining of each row with values 2
Conditional format : return to default format 5
Code does not error but no copy either 4
Convert list to UPPER, lower & Proper cases. 21
Adding comment to cells not working with merged cells 2

Top