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

 

[Fluff]

Hi & welcome to MrExcel
How about

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

   Select Case Target.Value
      Case "Prio1"
         If Not Evaluate("isref('" & Target.Value & "'!a1)") Then Sheets.Add.Name = "Prio1"
         Set ws = Sheets("Prio1")
      Case "Prio2"
         If Not Evaluate("isref('" & Target.Value & "'!a1)") Then Sheets.Add.Name = "Prio2"
         Set ws = Sheets("Prio2")
      Case "Prio3"
         If Not Evaluate("isref('" & Target.Value & "'!a1)") Then Sheets.Add.Name = "Prio3"
         Set ws = Sheets("Prio3")
   End Select
   Me.Activate
   If MsgBox("Move this project to " & Target.Value & "?", 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
Application.EnableEvents = True
   
End Sub

 

[Alminc]

Hi & welcome to MrExcel
How about

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

   Select Case Target.Value
      Case "Prio1"
         If Not Evaluate("isref('" & Target.Value & "'!a1)") Then Sheets.Add.Name = "Prio1"
         Set ws = Sheets("Prio1")
      Case "Prio2"
         If Not Evaluate("isref('" & Target.Value & "'!a1)") Then Sheets.Add.Name = "Prio2"
         Set ws = Sheets("Prio2")
      Case "Prio3"
         If Not Evaluate("isref('" & Target.Value & "'!a1)") Then Sheets.Add.Name = "Prio3"
         Set ws = Sheets("Prio3")
   End Select
   Me.Activate
   If MsgBox("Move this project to " & Target.Value & "?", 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
Application.EnableEvents = True
   
End Sub

Thank you for your answer. I tested the code that you posted and for some reason it's not working. When I pick the value from dropdown list nothing happens, the cell just gets that value , e.g. "Prio 1" and nothing happens.

 

[Fluff]

Firstly run this & see if that helps

sub Chk()
Application.EnableEvents = True
End sub

Secondly are your values/sheets names like Prio1, or Prio 1?

 

[dmt32]

Hi,
see if this update to your code does what you want

Option Base 1
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim answer As VbMsgBoxResult
    Dim ws As Worksheet, nextrow As Long
    Dim m As Variant, arr As Variant
    
    arr = Array("Prio1", "Prio2", "Prio3")
    
    If Target.Cells.Count > 1 Then Exit Sub
    
    If Not Intersect(Target, Columns("M:M")) Is Nothing Then
        Application.ScreenUpdating = False
        m = Application.Match(Target.Value, arr, False)
        If Not IsError(m) Then
            
            On Error Resume Next
            With ThisWorkbook
                Set ws = .Worksheets(arr(m))
                If ws Is Nothing Then .Worksheets.Add().Name = arr(m): Set ws = ActiveSheet
                nextrow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row + 1
            End With
            On Error GoTo exitsub
            
            answer = MsgBox("Move this project to " & arr(m) & "?", vbYesNo + vbQuestion, "Move Record")
            If answer = vbYes Then
                Target.EntireRow.Copy Destination:=Worksheets(arr(m)).Range("A" & nextrow)
                Target.EntireRow.Delete shift:=xlUp
            Else
                Me.Range("M:M").ClearContents
            End If
        End If
    End If
    
exitsub:
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    Set ws = Nothing
End Sub

Note Option Base 1 statement at top of Code - This MUST sit at very TOP of you sheets code page OUTSIDE any procedure.

Dave

 

[Alminc]

Firstly run this & see if that helps

sub Chk()
Application.EnableEvents = True
End sub

Secondly are your values/sheets names like Prio1, or Prio 1?

My sheets have names "Prio1" , "Prio2", "Prio3" (no space) and values in dropdown list are Prio 1, Prio 2, Prio 3 (with space).

I don't what to do with the code you just gave me, how to run it, to put it on the top of the previous code?

 

[Fluff]

Just put it in a standard module & run it.
Can you change either your sheet names or your drop down, so that they are the same?

 

[Alminc]

Just put it in a standard module & run it.
Can you change either your sheet names or your drop down, so that they are the same?

I changed the names so that they are all with the space now, like "Prio 1", and I managed to create module and put the three lines of code you gave me in it and ran that code. Now it works as intended.

Do I have to keep those three lines in that module or can I remove it now?

 

[Alminc]

Hi,
see if this update to your code does what you want

Option Base 1
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim answer As VbMsgBoxResult
    Dim ws As Worksheet, nextrow As Long
    Dim m As Variant, arr As Variant
    
    arr = Array("Prio1", "Prio2", "Prio3")
    
    If Target.Cells.Count > 1 Then Exit Sub
    
    If Not Intersect(Target, Columns("M:M")) Is Nothing Then
        Application.ScreenUpdating = False
        m = Application.Match(Target.Value, arr, False)
        If Not IsError(m) Then
            
            On Error Resume Next
            With ThisWorkbook
                Set ws = .Worksheets(arr(m))
                If ws Is Nothing Then .Worksheets.Add().Name = arr(m): Set ws = ActiveSheet
                nextrow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row + 1
            End With
            On Error GoTo exitsub
            
            answer = MsgBox("Move this project to " & arr(m) & "?", vbYesNo + vbQuestion, "Move Record")
            If answer = vbYes Then
                Target.EntireRow.Copy Destination:=Worksheets(arr(m)).Range("A" & nextrow)
                Target.EntireRow.Delete shift:=xlUp
            Else
                Me.Range("M:M").ClearContents
            End If
        End If
    End If
    
exitsub:
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    Set ws = Nothing
End Sub

Note Option Base 1 statement at top of Code - This MUST sit at very TOP of you sheets code page OUTSIDE any procedure.

Dave

Thank you very much dmt32, I tried your code and it works also, only I needed to change the way I named the sheets, i the sheet names and the items in list were not same : )

 

[Fluff]

Glad we could help & thanks for the feedback

Do I have to keep those three lines in that module or can I remove it now?

No you can get rid of them.