Selectively copy and paste rows with given criteria - excel

Question

I am trying to select rows in a table based on the word "Yes" being present in column J.
I have a table going from column A to J, and I want to select the rows where there is a "Yes" in column J and paste only those rows into a new sheet.
Once selected, I need to copy these rows to a new sheet or word document.
I have tried a range of forumulas, this is for Windows MS Excel software, using a VBA Macro.
I am using the following VBA, but having issues:
Sub Macro1()
Dim rngJ As Range
Dim cell As Range
Set rngJ = Range("J1", Range("J65536").End(xlUp))
Set wsNew = ThisWorkbook.Worksheets.Add
For Each cell In rngJ
If cell.Value = "Yes" Then
cell.EntireRow.Copy
wsNew.Sheets("Sheet1").Range("J65536").End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste
End If
Next cell
End Sub
Any help would be very much appreciated!

Answer 1

Rather than finding, copying and pasting for each cell, why not find all, then copy and paste once like this:
Sub Macro1()
Dim rngJ As Range
Dim MySel As Range
Set rngJ = Range("J1", Range("J" & Rows.Count).End(xlUp))
Set wsNew = ThisWorkbook.Worksheets.Add
For Each cell In rngJ
If cell.Value = "Yes" Then
If MySel Is Nothing Then
Set MySel = cell.EntireRow
Else
Set MySel = Union(MySel, cell.EntireRow)
End If
End If
Next cell
If Not MySel Is Nothing Then MySel.Copy Destination:= wsNew.Range("A1")
End Sub
It's better to avoid using Select as much as possible; see this link.

Answer 2

Use something like this
Option Explicit
Public Sub CopyYesRowsToNewWorksheet()
Dim wsSource As Worksheet
Set wsSource = ThisWorkbook.ActiveSheet 'better define sheet by name ThisWorkbook.Worksheets("SourceSheet")
Dim DataRangeJ As Variant 'read "yes" data into array for faster access
DataRangeJ = wsSource.Range("J1", wsSource.Range("J" & wsSource.Rows.Count).End(xlUp)).Value
Dim wsNew As Worksheet
Set wsNew = ThisWorkbook.Worksheets.Add
Dim NextFreeRow As Long
NextFreeRow = 1 'start pasting in this row in the new sheet
If IsArray(DataRangeJ) Then
Dim iRow As Long
For iRow = LBound(DataRangeJ) To UBound(DataRangeJ) 'loop through data array
If DataRangeJ(iRow, 1) = "yes" Then
wsNew.Rows(NextFreeRow).Value = wsSource.Rows(iRow).Value 'copy the values of the row
NextFreeRow = NextFreeRow + 1
End If
Next iRow
ElseIf DataRangeJ = "yes" Then 'if only the first row has data
wsNew.Rows(NextFreeRow).Value = wsSource.Rows(1).Value
End If
End Sub
The line
wsNew.Rows(NextFreeRow).Value = wsSource.Rows(iRow).Value
only copys the value without formatting. If you also want to copy the formatting replace it with
wsSource.Rows(iRow).Copy Destination:=wsNew.Rows(NextFreeRow)