VBA Move Row to Another Sheet Based on 2 Criteria

[AMD00010]

Hello --

Looking for help with the following situation.

I'd like to move an entire row from "Worksheet 1: Pending Items" to another Worksheet based on the value in Column 1 and the Status in Column 3. In my simplified example below (header row in bold), I'd like Row 3 from "Worksheet 1: Pending Items" to move to "Worksheet 2: Div 02" when the Status is marked close and because the Value in Column 1 is 02. This would repeat for all values in Column 1; i.e. Row 4 would move to "Worksheet 3: Div 03" when the Status in Column 3 is marked Closed. And so on.

Anyone have a solution I can try? Thanks in advance.

Worksheet 1: Pending Items
[TABLE="width: 500"]
<tbody>[TR]
[TD][/TD]
[TD]Column 1[/TD]
[TD]Column 2[/TD]
[TD]Column 3[/TD]
[/TR]
[TR]
[TD]Row 1 (Header)[/TD]
[TD]Div #[/TD]
[TD]Type.[/TD]
[TD]Status[/TD]
[/TR]
[TR]
[TD]Row 2[/TD]
[TD]01[/TD]
[TD]Example 1[/TD]
[TD]Open[/TD]
[/TR]
[TR]
[TD]Row 3[/TD]
[TD]02[/TD]
[TD]Example 2[/TD]
[TD]Closed[/TD]
[/TR]
[TR]
[TD]Row 4[/TD]
[TD]03[/TD]
[TD]Example 3[/TD]
[TD]Closed[/TD]
[/TR]
</tbody>[/TABLE]

Worksheet 2: Div 02
[TABLE="width: 500"]
<tbody>[TR]
[TD]Div #[/TD]
[TD]Type.[/TD]
[TD]Status[/TD]
[/TR]
[TR]
[TD]02[/TD]
[TD]Example 2[/TD]
[TD]Closed[/TD]
[/TR]
</tbody>[/TABLE]

Worksheet 3: Div 03
[TABLE="width: 500"]
<tbody>[TR]
[TD]Div #[/TD]
[TD]Type.[/TD]
[TD]Status[/TD]
[/TR]
[TR]
[TD]03[/TD]
[TD]Example 3[/TD]
[TD]Closed[/TD]
[/TR]
</tbody>[/TABLE]

 

[My Aswer Is This]

Put this script in sheet named Pending.
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

Script will run when value "Closed" is entered into column C on sheet named Pending

Private Sub Worksheet_Change(ByVal Target As Range)
'Modified  7/14/2018  9:45:50 PM  EDT
If Not Intersect(Target, Range("C:C")) Is Nothing Then
If Target.Cells.CountLarge > 1 Or IsEmpty(Target) Then Exit Sub
Dim ans As Long
If Target.Value = "Closed" Then
Dim Lastrow As Long
ans = Target.Row
Lastrow = Sheets("Div " & Cells(ans, 2).Value).Cells(Rows.Count, "A").End(xlUp).Row + 1
Rows(ans).Copy Sheets("Div " & Cells(ans, 2).Value).Rows(Lastrow)
Rows(ans).Delete
End If
End If
End Sub

 

[AMD00010]

Thank you so much for your response. I inserted the script into the Pending worksheet and received an error that says "Run-time error '9': Subscript out of range." When I hit "De-bug" the 7th line of the script (starting "Lastrow = Sheets..") is highlighted. Any idea what's causing the issue?

I think it might be helpful if I supply some additional information.
- As background the spreadsheet is to manage requests for information related to a building under construction. All queries are organized by Division # - and Division #s typically range from 01-33. The Pending tab will list all queries submitted and pending a response. The additional tabbed worksheets will include all items closed (answered). So, we will have up to 33 additional tabs with closed queries listed as reference/for our record.
- Some queries will include a "Resubmit" response option (as opposed to Open or Closed). I found a script on the forum that moved the Resubmit items successfully to another worksheet called "Resubmit." I thought I could replicate the script, but got stuck when I realized the additional Criteria of the Division # would change the script I used. The script I successfully used for "Resubmit" is one you wrote back in 2016, found here: https://www.mrexcel.com/forum/excel-questions/956476-vba-move-row-another-sheet-based-criteria.html.
- I used a simplified version of my spreadsheet columns, but please let me know if I should post the example with the complete number of columns.

Any feedback/help very much appreciated. Please let me know if I can provide more details.

THANK YOU.

 

[My Aswer Is This]

Try this:

Private Sub Worksheet_Change(ByVal Target As Range)
'Modified  7/16/2018  2:17:01 PM  EDT
If Not Intersect(Target, Range("C:C")) Is Nothing Then
If Target.Cells.CountLarge > 1 Or IsEmpty(Target) Then Exit Sub
Dim ans As Long
If Target.Value = "Closed" Then
Dim Lastrow As Long
ans = Target.Row
Lastrow = Sheets("Div " & Cells(ans, 1).Value).Cells(Rows.Count, "A").End(xlUp).Row + 1
Rows(ans).Copy Sheets("Div " & Cells(ans, 1).Value).Rows(Lastrow)
Rows(ans).Delete
End If
End If
End Sub

 

[AMD00010]

Thank you. This works. However, I can't get the 2 scripts to go at once. Only one or the other. I'm getting the ambiguous name message. Advice? Sorry, I'm new and not sure how to resolve this on my own. THANK YOU.

 

[My Aswer Is This]

So I need to see the other script.
I see nothing in your original post about two scripts.

 

[AMD00010]

My apologies.

Here's the other script:

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("C:C")) Is Nothing Then
If Target.Cells.Count > 1 Or IsEmpty(Target) Then Exit Sub
Dim Lastrow As Long
Lastrow = Sheets("Resubmit").Cells(Rows.Count, "C").End(xlUp).Row + 1


If Target.Value = "Resubmit" Then Rows(Target.Row).Copy Destination:=Sheets("Resubmit").Rows(Lastrow)
Rows(Target.Row).Delete
End If
End Sub



Column C/Status has 3 total options: Open (no action occurs); Closed - Row moves to Div 1, or Div 2, etc. worksheet; Resubmit - Row moves to worksheet entitled Resubmit.

 

[My Aswer Is This]

Try this:

Private Sub Worksheet_Change(ByVal Target As Range)
'Modified  7/16/2018  4:26:07 PM  EDT
If Not Intersect(Target, Range("C:C")) Is Nothing Then
If Target.Cells.CountLarge > 1 Or IsEmpty(Target) Then Exit Sub
Dim ans As Long
Dim Lastrow As Long
Dim Lastrowa As Long
    If Target.Value = "Closed" Then
        ans = Target.Row
        Lastrow = Sheets("Div " & Cells(ans, 1).Value).Cells(Rows.Count, "A").End(xlUp).Row + 1
        Rows(ans).Copy Sheets("Div " & Cells(ans, 1).Value).Rows(Lastrow)
        Rows(ans).Delete
        Exit Sub
    End If

    If Target.Value = "Resubmit" Then
        ans = Target.Row
        Lastrowa = Sheets("Resubmit").Cells(Rows.Count, "C").End(xlUp).Row + 1
        Rows(ans).Copy Destination:=Sheets("Resubmit").Rows(Lastrowa)
    Rows(ans).Delete
    End If
End If
End Sub

 

[AMD00010]

WOW. Thank you. This works in my test. I'll integrate it into the larger spreadsheet tomorrow. Many thanks for your time.

 

[My Aswer Is This]

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

WOW. Thank you. This works in my test. I'll integrate it into the larger spreadsheet tomorrow. Many thanks for your time.