VBA code to move entire rows from one sheet to 3 different sheets based on cell values from dropdown list

[Alminc]

Hello,

I am trying to use VBA code in order to move entire rows from sheet1 named "New Projects" to 3 different sheets, based on cell value picked from in-cell dropdown list in sheet1.

I am not a coder but I could understand a little and fond a piece of code somewhere on the internet.

So far I found the code that can move a row from my sheet1 ("New Projects") to other sheet named "Prio1", if the cell value picked from dropdown list becomes "Prio 1" (meaning that I am moving that new project (entire row) to sheet "Prio1" because it has priority number 1.

But I have even the sheets named Prio2 and Prio3 where I need to move the rows when the value in the cell is "Prio 2" or "Prio 3", and I dont know how to do it.

If I just copy/paste same code in the editor and only change sheet names then I get some error message "Ambiguous name Worksheet_Change" and it doesn't work.


This is the piece of code that I found and it works for moving rows to Prio1:

Option Explicit
    
    Private Sub Worksheet_Change(ByVal Target As Range)
    
        Dim answer As Integer
    
        Dim lngRow As Long, ws As Worksheet, nextrow As Long
            
        If Target.Cells.Count > 1 Then Exit Sub
        
        Application.ScreenUpdating = False
        
        If Not Intersect(Target, Columns("M:M")) Is Nothing Then
            If Target.Value = "Prio 1" Then
                lngRow = Target.Row
                On Error Resume Next
                With ThisWorkbook
                    Set ws = Worksheets("Prio1")
                    If ws Is Nothing Then .Worksheets.Add().Name = "Prio1"
                    nextrow = Worksheets("Prio1").Cells(Rows.Count, "A").End(xlUp).Row + 1
                End With
                With Sheet1 'code name
                    answer = MsgBox("Move this project to Prio1?", vbYesNo + vbQuestion)
                If answer = vbYes Then
                    .Range("A" & lngRow).EntireRow.Copy Destination:=Worksheets("Prio1").Range("A" & nextrow)
                    .Range("A" & lngRow).EntireRow.Delete shift:=xlUp
                Else
                     Worksheets("New Projects").Range("M:M").ClearContents 
                     
                End If
                
                End With
            End If
        End If
        Application.CutCopyMode = False
        Application.ScreenUpdating = True
        Set ws = Nothing
        
    End Sub

Now I need help to add equivalent code for "Prio2" anf "Prio3" to the code above.

Can someone please help me out?


Almin

 

[Alminc]

I have one more question: Instead of
"Else
Range("M:M").ClearContents "

can I use some code to only clear the active cell, not the whole column?

 

[Fluff]

Try

Target.ClearContents

 

[Alminc]

Works fine, thank you.

 

[Fluff]

You're welcome

 

[Alminc]

You're welcome

Hey Fluff, I'd like to add another messagebox after the first one, that asks "Do you want to open "& Target.Value &" now?".
If answer is Yes, the corresponding sheet should open.

Can you help with that?

 

[Fluff]

Try

Private Sub Worksheet_Change(ByVal Target As Range)
   
   Dim Ans As String
   Dim ws As Worksheet, nextrow As Long
   Dim Sht As String
   
   If Target.CountLarge > 1 Then Exit Sub
   If Intersect(Target, Columns("M:M")) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Application.EnableEvents = False

   Sht = Target.Value
   Select Case Sht
      Case "Prio1"
         If Not Evaluate("isref('" & Sht & "'!a1)") Then Sheets.Add.Name = "Prio1"
         Set ws = Sheets("Prio1")
      Case "Prio2"
         If Not Evaluate("isref('" & Sht & "'!a1)") Then Sheets.Add.Name = "Prio2"
         Set ws = Sheets("Prio2")
      Case "Prio3"
         If Not Evaluate("isref('" & Sht & "'!a1)") Then Sheets.Add.Name = "Prio3"
         Set ws = Sheets("Prio3")
   End Select
   Me.Activate
   If MsgBox("Move this project to " & Sht & "?", vbYesNo + vbQuestion) = vbYes Then
      Target.EntireRow.Copy ws.Range("A" & Rows.Count).End(xlUp).Offset(1)
      Target.Select
      Target.EntireRow.Delete
   Else
      Range("M:M").ClearContents
   End If
   If MsgBox("Do you want to open " & Sht & " now?", vbYesNo + vbQuestion) = vbYes Then
      Sheets(Sht).Activate
   End If
Application.EnableEvents = True
   
End Sub

 

[Alminc]

Try

Private Sub Worksheet_Change(ByVal Target As Range)
   
   Dim Ans As String
   Dim ws As Worksheet, nextrow As Long
   Dim Sht As String
   
   If Target.CountLarge > 1 Then Exit Sub
   If Intersect(Target, Columns("M:M")) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Application.EnableEvents = False

   Sht = Target.Value
   Select Case Sht
      Case "Prio1"
         If Not Evaluate("isref('" & Sht & "'!a1)") Then Sheets.Add.Name = "Prio1"
         Set ws = Sheets("Prio1")
      Case "Prio2"
         If Not Evaluate("isref('" & Sht & "'!a1)") Then Sheets.Add.Name = "Prio2"
         Set ws = Sheets("Prio2")
      Case "Prio3"
         If Not Evaluate("isref('" & Sht & "'!a1)") Then Sheets.Add.Name = "Prio3"
         Set ws = Sheets("Prio3")
   End Select
   Me.Activate
   If MsgBox("Move this project to " & Sht & "?", vbYesNo + vbQuestion) = vbYes Then
      Target.EntireRow.Copy ws.Range("A" & Rows.Count).End(xlUp).Offset(1)
      Target.Select
      Target.EntireRow.Delete
   Else
      Range("M:M").ClearContents
   End If
   If MsgBox("Do you want to open " & Sht & " now?", vbYesNo + vbQuestion) = vbYes Then
      Sheets(Sht).Activate
   End If
Application.EnableEvents = True
   
End Sub

Thank you very much. This almost does what I wanted, except the second box appears regardless of what the answer in the first box is. I would like the second box to appear only if the answer in the first box is Yes. Is it too much to wish?

 

[Fluff]

How about

   If MsgBox("Move this project to " & Sht & "?", vbYesNo + vbQuestion) = vbYes Then
      Target.EntireRow.Copy ws.Range("A" & Rows.Count).End(xlUp).Offset(1)
      Target.Select
      Target.EntireRow.Delete
      If MsgBox("Do you want to open " & Sht & " now?", vbYesNo + vbQuestion) = vbYes Then Sheets(Sht).Activate
   Else
      Target.ClearContents
   End If

 

[Alminc]

This is exactly what I wanted. Thank you 1000 times : )

 

[Fluff]

You're welcome