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?

Am i overcomplication this macro - i mean it seems quite simple but yet I feel l might be overcoding it? — BobSki, May 01 '17 at 19:52
Just looking briefly you have "Sheets("NewSheet").Cells(i, "A")" as a destination for the row but you never defined or set "i". Also if you are cutting the row you probably don't need to delete it? — Wedge, May 01 '17 at 19:57
You also need to set `i = 1` before the loop starts. So when it first gets to that line, it's looking to paste in row `0`, which doesn't exist. Also, you'll need to somehow increment `i`, as after the first cut, it'll just copy the data over that line, instead of add it to a new one. Perhaps add `i = i + 1` after the `n = n + 1` for the simplest way — BruceWayne, May 01 '17 at 19:57
@Wedge - I'm trying to delete the empty row so there's no empty gap----thanks — BobSki, May 01 '17 at 20:03

BruceWayne · Accepted Answer · 2017-05-01T20:24:04.037

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.

This works perfectly - my only question is when i paste it, am i able to paste it so that formatting is the same as it is on the sheet that I'm copying it from?! I've done it before like this .Range("A1").pasteSpecial xlPasteValue but Not sure how I would do this here — BobSki, May 01 '17 at 20:07

score 1 · Answer 2 · answered May 01 '17 at 20:07

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

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

2 Answers2