Copy And Paste Rows When Condition is Met VBA

[Lance S]

I'm struggling to make the code I have work for the below. For anything in column J that returns "Yes", I want the entire row to to be copied and pasted in another sheet starting at row 4 on the new sheet. After executing, I want the original row on the original sheet to then be deleted and for the code to the continuously execute until the data in cell A is empty.

This is what I have so far. I run into an issue with the line VLV.Cells(Rows.Count, "J").End (xlUp) + 4 = ActiveCell.Row (I know this line is completely wrong but I'm not sure how to fix)

ub VPLTest()

Application.ScreenUpdating = False

Activesheet.Unprotect Password:="purc"

Dim VLV As Worksheet
Dim PCF As Worksheet
Set VLV = Activesheet

Sheets.Add after:=Activesheet
Activesheet.Name = "PCF Items"

Set PCF = Activesheet

VLV.Range("A1:N4").Copy PCF.Range("A1:N4")

VLV.Select
VLV.Range("J5").Select

Do Until ActiveCell = ""
If ActiveCell.Value = "Yes" Then
VLV.Cells(Rows.Count, "J").End (xlUp) + 4 = ActiveCell.Row
End If
If ActiveCell = "Yes" Then EntireRow.Delete

Loop

 

[Lance S]

Anyone have any ideas?

 

[johnnyL]

Couple questions:

1) The table of data you posted shows columns B thru K, but your code mentions A thru N.
2) You said you want the code to execute until cell A is empty? Explain that please.
3) Your indicates that you want to copy the first 4 rows from VLV right after the new sheet is created. Do you still want that to occur and then start processing the 'Yes' column after row 4, or is A1:N4 not included in your table from the original post?

In other words does the table you show start at row 1 or row 5?

 

[Lance S]

Sorry! Didn't notice it was missing. The reason I want it to execute until cell A in the row series in empty is because the Yes/No options in column J can sometimes be blank while column A never is.

I do want it to occur after row 4. The first 4 rows of both sheets are headers. The table should start at row 5.

 

[johnnyL]

So the following:

VLV.Range("A1:N4").Copy PCF.Range("A1:N4")

Needs to be executed to copy your headers over to the new sheet?

Also, is your table in any particular order, in other words does it matter which order the cut rows are placed in the new sheet?

 

[Lance S]

Yes sir!

 

[johnnyL]

see part 2 to my last post please

 

[Lance S]

Nope, the order does not matter

 

[johnnyL]

Got it, thank you for the clarifications.

 

[johnnyL]

How about this:

Sub VPLTest()
'
    Dim LastRow         As Long
    Dim CurrentRow      As Long
    Dim SourceSheetName As String
'
    SourceSheetName = "VLV"                                             ' <--- Set this to name of the Source sheet
'
    Application.ScreenUpdating = False                                              ' Turn ScreenUpdating off to prevent screen flicker
'
    Sheets(SourceSheetName).Unprotect Password:="purc"                              ' unprotect the Source sheet
'
    Sheets.Add after:=Sheets(SourceSheetName)                                       ' Add a new sheet after the Source sheet
    ActiveSheet.Name = "PCF Items"                                                  ' Assign a name to newly created sheet
'
    Sheets(SourceSheetName).Range("A1:N4").Copy Sheets("PCF Items").Range("A1:N4")  ' Copy Header rows from Source sheet to the new sheet
'
    LastRow = Sheets(SourceSheetName).Range("A" & Rows.Count).End(xlUp).Row         ' Determine Last used row in column A
'
    For CurrentRow = LastRow To 5 Step -1                                           ' Start at LastRow and work backwards, row by row, until beginning of data
        If Sheets(SourceSheetName).Range("J" & CurrentRow).Value Like "*Yes*" Then  '   If we encounter a 'Yes' in column J then copy the row to new sheet
            Sheets(SourceSheetName).Rows(CurrentRow).Copy Sheets("PCF Items").Range("A" & Rows.Count).End(xlUp).Offset(1)
            Sheets(SourceSheetName).Rows(CurrentRow).Delete                         '   Delete the row from the Source sheet that contained 'Yes' in column J
        End If
    Next                                                                            ' Continue checking previous row
'
    Sheets(SourceSheetName).Protect Password:="purc"                                ' protect the Source sheet
'
    Application.ScreenUpdating = True                                               ' Turn ScreenUpdating back on
End Sub