looping through an entire column of values and if value matches, cut and paste it to another sheet

Question

I have columns A, B, C, D, and E with data.

My goal is to start in cell A1, loop through every single record in column A while looking for a particular value "Grey". If the text in cells is equal to "Grey" then i want to cut and paste then entire row to a newly created sheet, starting in A1. here's what my code looks like ....

Dim n As Long
Dim nLastRow As Long
Dim nFirstRow As Long
Dim lastRow As Integer

ActiveSheet.UsedRange

Set r = ActiveSheet.UsedRange
nLastRow = r.Rows.Count + r.Row - 1
nFirstRow = r.Row

Worksheets("Original").Activate
With Application
.ScreenUpdating = False


Sheets.Add.Name = "NewSheet"

Sheets("Original").Select
Range("A1").Select

Set r = ActiveSheet.UsedRange
nLastRow = r.Rows.Count + r.Row - 1
nFirstRow = r.Row

With ActiveSheet
    For n = nLastRow To nFirstRow Step -1
        If .Cells(n, "A") = "Grey" Then
            .Cells(n, "A").EntireRow.Cut Sheets("NewSheet").Cells(i, "A")
            .Cells(n, "A").EntireRow.Delete
            n = n + 1
        End If
    Next
End With

.ScreenUpdating = True
End With

So this macro creates a new sheet - however when it gets to a cell where the value is grey it gives me an error on this line....

.Cells(n, "A").EntireRow.Cut Sheets("NewSheet").Cells(i, "A")

Error says:

Application defined or object defined error.

Anyone have any idea why?

Answer 1

You need to declare i , and set it. As mentioned, the first time it occurs it's looking to paste in row 0 , which doesn't exist.

Also, it's best to avoid using .Select / .Activate , and work directly with the data.

How does this work?

Sub t()
Dim r As Range
Dim n       As Long, i As Long, nLastRow As Long, nFirstRow As Long
Dim lastRow As Integer
Dim origWS As Worksheet, newWS As Worksheet

Set origWS = Worksheets("Original")
Set newWS = Sheets.Add
newWS.Name = "NewSheet"

Set r = origWS.UsedRange
nLastRow = r.Rows.Count + r.Row - 1
nFirstRow = r.Row

i = 1

With Application
    .ScreenUpdating = False
    With origWS
        For n = nLastRow To nFirstRow Step -1
            If .Cells(n, "A") = "Grey" Then
                .Cells(n, "A").EntireRow.Copy newWS.Cells(i, "A")
                .Cells(n, "A").EntireRow.Delete
                i = i + 1
            End If
        Next
    End With
    .ScreenUpdating = True
End With
End Sub

You also don't need to do n = n + 1 (unless I missed something).

Edit: Changed .Cut to .Copy , per OP's wish to keep formatting.

Answer 2

Or you may try something like this...

Sub CopyToNewSheet()
Dim sws As Worksheet, dws As Worksheet
Application.ScreenUpdating = False
Set sws = Sheets("Original")
On Error Resume Next
Set dws = Sheets("NewSheet")
dws.Cells.Clear
On Error GoTo 0

If dws Is Nothing Then
    Sheets.Add(after:=sws).Name = "NewSheet"
    Set dws = ActiveSheet
End If
sws.Rows(1).Insert
On Error Resume Next
With sws.Range("A1").CurrentRegion
    .AutoFilter field:=1, Criteria1:="Grey"
    .SpecialCells(xlCellTypeVisible).Copy dws.Range("A1")
    .SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
dws.Rows(1).Delete
Application.ScreenUpdating = True
End Sub