VBA - How do I cut and paste a row to another worksheet when 2 cells both say Yes

[BobAjob200]

Hello, I am very new to using VBA and don't really understand much at the minute.

I am trying to get it where when the word "Yes" is selected in both drop down boxes in columns V & W, that row is then cut and pasted into the worksheet "Delivered".
I then obviously want it to paste to the next row down as I want to still see all the data in that worksheet.

If you can also code deleting the row from the "Scheduled" worksheet (the main live/active tracker) that would be awesome!!

I'm not sure if this makes it easier or harder but it would be good to set up a button so that when I clicked it then that's when these Macro's activate and move over to the other worksheet.

 

[LazyBug]

Hello! If I understood your goal correctly (didn't check, try on a copy of your data!):

Public Sub ToDelivered()
    Dim ShSh As Worksheet, DlSh As Worksheet
    Dim DlRow As Long, EachRow As Long, ShRow As Long

        Set ShSh = ThisWorkbook.Worksheets("Sheduled")
        Set DlSh = ThisWorkbook.Worksheets("Delivered")
        ShRow = ShSh.Cells(ShSh.Rows.Count, 1).End(xlUp).Row
        DlRow = DlSh.Cells(DlSh.Rows.Count, 1).End(xlUp).Row + 1
       
        For EachRow = ShRow To 2 Step -1
            If ShSh.Cells(EachRow, 22).Value = "Yes" And ShSh.Cells(EachRow, 23).Value = "Yes" Then
                ShSh.Range(Cells(EachRow, 1), Cells(EachRow, 24)).Copy DlSh.Cells(DlRow, 1)
                DlRow = DlRow + 1
                ShSh.Rows(EachRow).EntireRow.Delete
            End If
        Next EachRow
End Sub

 

[mumps]

Different approach without looping:

Sub CutRows()
    Application.ScreenUpdating = False
    Dim desWS As Worksheet, srcWS As Worksheet
    Set desWS = Sheets("Delivered")
    Set srcWS = Sheets("Scheduled")
    With srcWS
        .Cells(1, 1).CurrentRegion.AutoFilter 22, "Yes"
        .Cells(1, 1).CurrentRegion.AutoFilter 23, "Yes"
        .AutoFilter.Range.Offset(1).Copy desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1)
        .AutoFilter.Range.Offset(1).EntireRow.Delete
        .Range("A1").AutoFilter
    End With
    Application.ScreenUpdating = True
End Sub

 

[BobAjob200]

Hello! If I understood your goal correctly (didn't check, try on a copy of your data!):

Public Sub ToDelivered()
    Dim ShSh As Worksheet, DlSh As Worksheet
    Dim DlRow As Long, EachRow As Long, ShRow As Long

        Set ShSh = ThisWorkbook.Worksheets("Sheduled")
        Set DlSh = ThisWorkbook.Worksheets("Delivered")
        ShRow = ShSh.Cells(ShSh.Rows.Count, 1).End(xlUp).Row
        DlRow = DlSh.Cells(DlSh.Rows.Count, 1).End(xlUp).Row + 1
      
        For EachRow = ShRow To 2 Step -1
            If ShSh.Cells(EachRow, 22).Value = "Yes" And ShSh.Cells(EachRow, 23).Value = "Yes" Then
                ShSh.Range(Cells(EachRow, 1), Cells(EachRow, 24)).Copy DlSh.Cells(DlRow, 1)
                DlRow = DlRow + 1
                ShSh.Rows(EachRow).EntireRow.Delete
            End If
        Next EachRow
End Sub

This gives me run-time error 9 "Subscript out of range"

 

[BobAjob200]

Different approach without looping:

Sub CutRows()
    Application.ScreenUpdating = False
    Dim desWS As Worksheet, srcWS As Worksheet
    Set desWS = Sheets("Delivered")
    Set srcWS = Sheets("Scheduled")
    With srcWS
        .Cells(1, 1).CurrentRegion.AutoFilter 22, "Yes"
        .Cells(1, 1).CurrentRegion.AutoFilter 23, "Yes"
        .AutoFilter.Range.Offset(1).Copy desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1)
        .AutoFilter.Range.Offset(1).EntireRow.Delete
        .Range("A1").AutoFilter
    End With
    Application.ScreenUpdating = True
End Sub

This is not working, I have no errors but it just isn't moving anything. FYI, I have added another column so the columns I need checking are W & X. I have found the below code which works for me but it doesn't check the columns, it just checks to see if the word "Yes" is in the row so if you can get this code to say look in columns W & X for the word Yes then that would be perfect!!

Sub Worksheet_Change(ByVal Target As Range)

Dim ows As Worksheet
Dim nws As Worksheet
Dim lr As Long

' Set name of worksheet to copy to, and name of current sheet
Set nws = Sheets("Delivered")
Set ows = ActiveSheet

' Exit if more than one cell updated
If Target.CountLarge > 1 Then Exit Sub

' Check to see if row > 1 and value is "Yes"
If (Target.Row > 1) And (Target.Value = "Yes") Then
' Find first blank row on new sheet
lr = nws.Cells(Rows.Count, "A").End(xlUp).Row + 1
' Copy to new sheet
Application.EnableEvents = False
ows.Rows(Target.Row).Copy nws.Cells(lr, "A")
' Delete old row
ows.Rows(Target.Row).Delete
Application.EnableEvents = True
End If

End Sub

 

[LazyBug]

Try to replace in my code string

Set ShSh = ThisWorkbook.Worksheets("Sheduled")

with

Set ShSh = ThisWorkbook.Worksheets("Scheduled")

and

If ShSh.Cells(EachRow, 22).Value = "Yes" And ShSh.Cells(EachRow, 23).Value = "Yes" Then

for checking V and W columns with

If ShSh.Cells(EachRow, 23).Value = "Yes" And ShSh.Cells(EachRow, 24).Value = "Yes" Then

for W and X.

 

[mumps]

Try:

Sub CutRows()
    Application.ScreenUpdating = False
    Dim desWS As Worksheet, srcWS As Worksheet
    Set desWS = Sheets("Delivered")
    Set srcWS = Sheets("Scheduled")
    With srcWS
        .Cells(1, 1).CurrentRegion.AutoFilter 23, "Yes"
        .Cells(1, 1).CurrentRegion.AutoFilter 24, "Yes"
        .AutoFilter.Range.Offset(1).Copy desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1)
        .AutoFilter.Range.Offset(1).EntireRow.Delete
        .Range("A1").AutoFilter
    End With
    Application.ScreenUpdating = True
End Sub

 

[BobAjob200]

Try to replace in my code string

Set ShSh = ThisWorkbook.Worksheets("Sheduled")

with

Set ShSh = ThisWorkbook.Worksheets("Scheduled")

and

If ShSh.Cells(EachRow, 22).Value = "Yes" And ShSh.Cells(EachRow, 23).Value = "Yes" Then

for checking V and W columns with

If ShSh.Cells(EachRow, 23).Value = "Yes" And ShSh.Cells(EachRow, 24).Value = "Yes" Then

for W and X.

Perfect this works! Thank you! I had changed the row numbers to 23 and 24 for V & W but didn't even realise the word Scheduled misspelt

 

[BobAjob200]

Try:

Sub CutRows()
    Application.ScreenUpdating = False
    Dim desWS As Worksheet, srcWS As Worksheet
    Set desWS = Sheets("Delivered")
    Set srcWS = Sheets("Scheduled")
    With srcWS
        .Cells(1, 1).CurrentRegion.AutoFilter 23, "Yes"
        .Cells(1, 1).CurrentRegion.AutoFilter 24, "Yes"
        .AutoFilter.Range.Offset(1).Copy desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1)
        .AutoFilter.Range.Offset(1).EntireRow.Delete
        .Range("A1").AutoFilter
    End With
    Application.ScreenUpdating = True
End Sub

Yes this works thank you!

 

[mumps]

You are very welcome.