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

BobAjob200

New Member
Joined
Oct 28, 2020
Messages
5
Office Version
  1. 365
Platform
  1. Windows
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.
 

Attachments

  • Capture.PNG
    Capture.PNG
    43.3 KB · Views: 36
  • Capture1.PNG
    Capture1.PNG
    52.5 KB · Views: 34

Excel Facts

Which came first: VisiCalc or Lotus 1-2-3?
Dan Bricklin and Bob Frankston debuted VisiCalc in 1979 as a Visible Calculator. Lotus 1-2-3 debuted in the early 1980's, from Mitch Kapor.
Hello! If I understood your goal correctly (didn't check, try on a copy of your data!):
VBA Code:
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
 
Last edited:
Upvote 0
Different approach without looping:
VBA Code:
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
 
Upvote 0
Hello! If I understood your goal correctly (didn't check, try on a copy of your data!):
VBA Code:
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"
 
Upvote 0
Different approach without looping:
VBA Code:
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
 
Upvote 0
Try to replace in my code string
VBA Code:
Set ShSh = ThisWorkbook.Worksheets("Sheduled")
with
VBA Code:
Set ShSh = ThisWorkbook.Worksheets("Scheduled")
and
VBA Code:
If ShSh.Cells(EachRow, 22).Value = "Yes" And ShSh.Cells(EachRow, 23).Value = "Yes" Then
for checking V and W columns with
VBA Code:
If ShSh.Cells(EachRow, 23).Value = "Yes" And ShSh.Cells(EachRow, 24).Value = "Yes" Then
for W and X.
 
Upvote 0
Try:
VBA Code:
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
 
Upvote 0
Try to replace in my code string
VBA Code:
Set ShSh = ThisWorkbook.Worksheets("Sheduled")
with
VBA Code:
Set ShSh = ThisWorkbook.Worksheets("Scheduled")
and
VBA Code:
If ShSh.Cells(EachRow, 22).Value = "Yes" And ShSh.Cells(EachRow, 23).Value = "Yes" Then
for checking V and W columns with
VBA Code:
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
 
Upvote 0
Try:
VBA Code:
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!
 
Upvote 0

Forum statistics

Threads
1,223,214
Messages
6,170,774
Members
452,353
Latest member
strainu

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top