VBA to move rows based on multiple criteria

Maltman07

New Member
Joined
Oct 4, 2021
Messages
2
Office Version
  1. 2019
Platform
  1. Windows
Hi all,

I am wondering if anyone can help with this following spreadsheet VBA – my knowledge to date, has been web searched, combined with a mixture of cut and pastes solutions posted on this forum ?. Unfortunately, my own knowledge doesn’t extend past that and I have been unable to get my sheet to fully work.

In my spreadsheet I note customer details on the ‘Initial Stage’ sheet and in Column ‘R’ there is drop down criteria list:

Booked,

In progress,

Quote sent out,

Not progressed,

Completed


What I am looking for is that if either ‘Completed’ or ‘Not progressed’ criteria are selected, then it will automatically move that row to the corresponding sheet titled, ‘Completed’ or ‘Not progressed’ and delete out the row from the ‘Initial Stage’ sheet.

At the moment I can only get rows to move to the ‘Completed’ sheet from the criteria and do not know how to add in the additional code for ‘Not progressed’ (completely stuck). The code I’ve got so far is:

VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)

ActiveSheet.Unprotect (1234)

Rows(ActiveCell.Row).Locked = False

If Intersect(Target, Range("R:R")) Is Nothing Then Exit Sub

Application.EnableEvents = False

If Target = "Completed" Then

Sheets("Completed").Unprotect (1234)

Target.EntireRow.Copy Sheets("Completed").Cells(Sheets("Completed").Rows.Count, "A").End(xlUp).Offset(1)

Target.EntireRow.Delete

End If

Application.EnableEvents = True

Sheets("Completed").Protect (1234)

ActiveSheet.Protect (1234)

End Sub



The sheets are protected with password 1234.

The ‘Completed’ sheet contains additional information for columns ‘S-U’ so I initially tired only moving information contained within columns ‘A-R’, however I couldn’t get it to insert on a new row (it was only transferring to its corresponding row and not into the first available one), which is why I went for moving the full row with ‘unlock /lock functions’ to maintain formatting… (as I said, I’m a newbie ??).

Any help /solutions would be greatly appreciated!


Mike.
 

Attachments

  • Completed.png
    Completed.png
    125.1 KB · Views: 40
  • Initial Stage.png
    Initial Stage.png
    126.7 KB · Views: 41
  • Not progressed.png
    Not progressed.png
    123.4 KB · Views: 38
Last edited by a moderator:

Excel Facts

Control Word Wrap
Press Alt+Enter to move to a new row in a cell. Lets you control where the words wrap.
Try this:
This is an auto sheet event script
Your Workbook must be Macro enabled
To install this code:
Right-click on the sheet tab
Select View Code from the pop-up context menu
Paste the code in the VBA edit window
I'm going to let you enter the protect, unprotect lines of code in the script

VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
'Modified  10/4/2021  7:01:41 AM  EDT
Dim Lastrow As Long
Dim Lastrowa As Long
Dim ans As Long
On Error GoTo M
ans = Target.Row

If Target.Column = 18 Then
Application.EnableEvents = False
Select Case Target.Value
    Case "Completed"
        Lastrow = Sheets("Completed").Cells(Rows.Count, "R").End(xlUp).Row + 1
        Rows(ans).Copy Sheets("Completed").Cells(Lastrow, 1)
        Rows(ans).Delete
   
    Case "Not progressed"
        Lastrow = Sheets("Not progressed").Cells(Rows.Count, "R").End(xlUp).Row + 1
        Rows(ans).Copy Sheets("Not progressed").Cells(Lastrow, 1)
        Rows(ans).Delete
    End Select
Application.EnableEvents = True
End If
Exit Sub
M:
MsgBox "We had a problem" & vbNewLine & "Maybe we do not have a sheet named" & vbNewLine & Target.Value
Application.EnableEvents = True
 
Upvote 0
Reply withdrawn.
Suitable reply supplied by M.A.I.T.
 
Last edited:
Upvote 0
I did forget one line of code at top:
Try this:
VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
'Modified  10/4/2021  7:26:41 AM  EDT
If Target.Count > 1 Then Exit Sub
Dim Lastrow As Long
Dim Lastrowa As Long
Dim ans As Long
On Error GoTo M
ans = Target.Row

If Target.Column = 18 Then
Application.EnableEvents = False
Select Case Target.Value
    Case "Completed"
        Lastrow = Sheets("Completed").Cells(Rows.Count, "R").End(xlUp).Row + 1
        Rows(ans).Copy Sheets("Completed").Cells(Lastrow, 1)
        Rows(ans).Delete
    
    Case "Not progressed"
        Lastrow = Sheets("Not progressed").Cells(Rows.Count, "R").End(xlUp).Row + 1
        Rows(ans).Copy Sheets("Not progressed").Cells(Lastrow, 1)
        Rows(ans).Delete
    End Select
Application.EnableEvents = True
End If
Exit Sub
M:
MsgBox "We had a problem" & vbNewLine & "Maybe we do not have a sheet named" & vbNewLine & Target.Value
Application.EnableEvents = True

End Sub
 
Upvote 0
Solution
Thanks for the help in this - a bit of tweaking and it works great! :)

Michael
 
Upvote 0

Forum statistics

Threads
1,223,243
Messages
6,170,964
Members
452,371
Latest member
Frana

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