How do you remove rows based on specific cell data in a column with a macro?

[evamarie]

I have a file that needs to have rows cut and moved to another worksheet inside the same active workbook, if the required data in a specific column is there. Here's the code which correctly selects the rows:

Sub SelectRowsCO()

Dim c As Range
Dim rngCO As Range
For Each c In Intersect(ActiveSheet.UsedRange, Columns("b"))
If c = "CO" Then
If rngCO Is Nothing Then Set rngCO = c.EntireRow
Set rngCO = Union(rngCO, c.EntireRow)
End If
Next c
rngCO.Select

End Sub

What I cannot figure out how is how to tell the macro to cut these selected rows and move them to sheet 2 in the same workbook, and then delete the now blank rows in sheet 1.

Any help would be greatly appreciated!

 

[VoG]

Try

Sub SelectRowsCO()
Dim c As Range
Dim rngCO As Range
For Each c In Intersect(ActiveSheet.UsedRange, Columns("b"))
If c = "CO" Then
    If rngCO Is Nothing Then
        Set rngCO = c.EntireRow
    Else
        Set rngCO = Union(rngCO, c.EntireRow)
    End If
Next c
rngCO.Cut Destination:=Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
On Error Resume Next
Columns("B").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0
End Sub

 

[evamarie]

Thanks VoG for your reply.

I copied the code and received the compile error: next without for.

I'm not a programmer by any stretch of the imagination, so could you please tell me what I'm missing?

Thanks again!
Eva Marie

 

[evamarie]

I forgot to mention the compile error highlights the code:

next c

 

[Rick Rothstein]

VoG accidentally left out an End If statement. Here is corrected code...

Sub SelectRowsCO()
    Dim c As Range
    Dim rngCO As Range
    For Each c In Intersect(ActiveSheet.UsedRange, Columns("b"))
        If c = "CO" Then
            If rngCO Is Nothing Then
                Set rngCO = c.EntireRow
            Else
                Set rngCO = Union(rngCO, c.EntireRow)
            End If
        End If
    Next c
    rngCO.Cut Destination:=Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
    On Error Resume Next
    Columns("B").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    On Error GoTo 0
End Sub

However, I would like you to try this non-looping code instead which should execute quite quickly...

Sub MoveCOdata()
  Dim LastColPlusOne As Long
  LastColPlusOne = Cells.Find(What:="*", SearchOrder:=xlByColumns, _
                   SearchDirection:=xlPrevious, LookIn:=xlFormulas).Column + 1
  With Columns("C")
    .Copy .Cells(1)
    .Replace "CO", "TRUE", xlWhole
    With .SpecialCells(xlCellTypeConstants, xlLogical).EntireRow
      .Copy Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
      .Replace "TRUE", "CO", xlWhole
      .Delete
    End With
  End With
End Sub

 

[evamarie]

Hi Rick,

Thanks for your reply and help.

I tried both codes and end up with an out of range error for each one. The range error shows up for the following lines:

In code 1:

rngCO.Cut Destination:=Sheets("Sheet2").Range("A2" & Rows.Count).End(xlUp).Offset(1)

and

In code 2:

.Copy Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)

Re: Sheet 2 - has a header row in row A, beginning in cells A1 through Q1, but nothing else. Sheet two is named "CO, MR, PO, PP"

Thanks again!
Eva Marie

 

[Rick Rothstein]

I didn't test VoG's code, but it looks like it should work and I know my code works because I tested it before posting it. Did you copy/paste my code into a standard Module before you tried running it (it runs as is, so you should not try to modify it)? Was the page where your data is located the active sheet when you ran the code (as written, my code requires this, but it can be changed to run from anywhere if that is what you need)?

 

[VoG]

Tested and working

Sub SelectRowsCO()
Dim c As Range
Dim rngCO As Range
For Each c In Intersect(ActiveSheet.UsedRange, Columns("b"))
    If c = "CO" Then
        If rngCO Is Nothing Then
            Set rngCO = c.EntireRow
        Else
            Set rngCO = Union(rngCO, c.EntireRow)
        End If
    End If
Next c
With rngCO
    .Copy Destination:=Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
    .Delete
End With
On Error Resume Next
Columns("B").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0
End Sub

 

[evamarie]

Hello Rick and VoG,

No, I didn't originally change the code, but figured out that's why it wasn't working. Apparently Sheet 2 (which used to be called "CO, MR, PO, PP") is actually Sheet 1 (not sure why) - anyway, I changed the code to "Sheet1" and it works great now.

Thanks so much for all your help folks!

Eva Marie