VBA to move rows based on multiple criteria

[Maltman07]

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:

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.

 

[My Aswer Is This]

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

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

 

[vcoolio]

Reply withdrawn.
Suitable reply supplied by M.A.I.T.

 

[My Aswer Is This]

I did forget one line of code at top:
Try this:

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

 

[Maltman07]

Thanks for the help in this - a bit of tweaking and it works great!

Michael

 

[My Aswer Is This]

Thanks for the help in this - a bit of tweaking and it works great!

Michael

Glad I was able to help you.
Come back here to Mr. Excel next time you need additional assistance.