Copy row from one sheet to another based on criteria in a column

Question

This workbook is setup for a userform to enter PO information so it can be added to a dynamic PO log. Once logged the user will close the userform and select a comboBox value Yes or No to indicate whether or not this PO should be deducted from the monthly budget.

If the user selects No the entire row should be copied to the next page in the workbook, which is also the next month. This should happen via a Worksheet Selection_Change Event only if the comboBox value = No.
If the user selects Yes other formulas will add the value to the total deductions so it should be ignored by the loop.

The pages in this workbook are exactly the same, so the range for the second month will be the same as the first month C14:H14, which again dynamically updates depending on how many NO values are selected.

I am having trouble finding only No values and copying the row C14:H14 to the next available row in the next worksheet.

Sub Transfer()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim lRow1 As Long
Dim lRow2 As Long
Dim i As Long
Dim Crit As Range

Set ws1 = ActiveSheet
Set ws2 = ActiveSheet.Next

lRow1 = ws1.Range("J" & Rows.Count).End(xlUp).Row

For i = 14 To lRow1
    If ws1.Cells(i, 10).Value = "No" Then

        ws1.Range("C" & i & ":H" & lRow1).Copy
        ws2.Activate

        lRow2 = ws2.Range("J" & Rows.Count).End(xlUp).Offset(1, 0).Row

        ws2.Range("C14:H" & lRow2).PasteSpecial Paste:=xlPasteValues
    End If
Next i

End Sub

This code copies the last two data points and ignores the condition. It will copy Yes and No if they are mixed throughout the data set.

user_478884 · Answer

You only need to copy each row - you're copying a whole block of rows instead

Sub Transfer()

    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim lRow1 As Long
    Dim lRow2 As Long
    Dim i As Long
    Dim Crit As Range
    
    Set ws1 = ActiveSheet
    Set ws2 = NextVisibleWorksheet(ws1) 'find next sheet
    If ws2 Is Nothing Then  'check we got a sheet
        msgbox "No sheet found after " & ws1.Name
        Exit sub
    End If
    
    lRow1 = ws1.Range("J" & Rows.Count).End(xlUp).Row
    lRow2 = ws2.Range("J" & Rows.Count).End(xlUp).Offset(1, 0).Row

    For i = 14 To lRow1
        If ws1.Cells(i, 10).Value = "No" Then
            With ws1.Range("C" & i & ":H" & i)
                ws2.Cells(lRow2, "C").Resize(1, .Columns.Count).Value = .Value
                lRow2 = lRow2 + 1
            End With
        End If
    Next i

End Sub

'given a worksheet, find the next visible sheet (if any)
Function NextVisibleWorksheet(ws As Worksheet)
    Dim rv As Worksheet
    Set rv = ws.Next 'does not raise an error if no more sheets...
    If Not rv Is Nothing Then
        Do While rv.Visible <> xlSheetVisible
            Set rv = rv.Next
            If rv Is Nothing Then Exit Do 'edit - added this check
        Loop
    End If
    Set NextVisibleWorksheet = rv
End Function

Copy row from one sheet to another based on criteria in a column

1 Answers