Move rows to another worksheet based on cell values

[jhenryp]

I want to move rows based on values entered in last column of a worksheet. If the value entered is "A" in worksheet "Active", I want to move the row to one worksheet starting in row 5. If the value entered is "B" in worksheet "Active", I want to move the row to another worksheet starting in row 5. And lastly, if the value entered is "C" in worksheet "Active", I want to move the row to another worksheet starting in row 5. Plus, anytime data is entered (A, B, or C), I want that row added to the other worksheets at the end of the last row of data.

I have this code I pulled from somewhere and adjusted but I have limited experience with VBA. Please help!

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("V:V")) Is Nothing Then
If Target.Cells.Count > 1 Or IsEmpty(Target) Then Exit Sub
Application.ScreenUpdating = False
Dim Lastrow As Long
Dim Lastrowa As Long
Lastrow = Sheets("Post Adoption - Approved").Cells(Rows.Count, "I").End(xlUp).Row
Lastrowa = Sheets("Active").Cells(Rows.Count, "I").End(xlUp).Row
If Target.Value = "Approved" Then
Rows(Target.Row).Copy Destination:=Sheets("Post Adoption - Approved").Rows(Lastrow)
Application.EnableEvents = False
Rows(Target.Row).Delete
Application.EnableEvents = True
Exit Sub
End If
Lastrow = Sheets("Post Adoption - Trial Period").Cells(Rows.Count, "I").End(xlUp).Row + 1
Lastrowa = Sheets("Active").Cells(Rows.Count, "I").End(xlUp).Row + 1
Application.EnableEvents = True
If Target.Value = "Trial" Then
Rows(Target.Row).Copy Destination:=Sheets("Post Adoption - Trial Period").Rows(Lastrowa)
Application.EnableEvents = False
Rows(Target.Row).Delete
End If
Lastrow = Sheets("Denied").Cells(Rows.Count, "I").End(xlUp).Row + 1
Lastrowa = Sheets("Active").Cells(Rows.Count, "I").End(xlUp).Row + 1
Application.EnableEvents = True
If Target.Value = "Denied" Then
Rows(Target.Row).Copy Destination:=Sheets("Denied").Rows(Lastrowa)
Application.EnableEvents = False
Rows(Target.Row).Delete
End If
Application.EnableEvents = True
Application.ScreenUpdating = True
End If
End Sub

 

[vcoolio]

Hello Jhenryp,

Can you confirm please:-
- That the last column is column V.
- The relevant sheet names: the source sheet and the destination sheets.

Cheerio,
vcoolio.

 

[jhenryp]

The last column is V.

Source Sheet: Active
Destination Sheets: Post Adoption - Approved (Value entered in V = Approved) , Post Adoption - Trial Period (Value entered in V = Trial) , Denied (Value entered in V = Denied)

 

[vcoolio]

Ok JHP,

Try the following code assigned to a button:-

Option Explicit

[CODE=vba]Sub Test()

        Dim wsA As Worksheet, wsD As Worksheet
        Dim ar As Variant, i As Integer
        Set wsA = Sheets("Active")
        ar = [{"Post Adoption-Approved","Post Adoption-Trial Period","Denied";"Approved","Trial","Denied"}]

Application.ScreenUpdating = False
      
        For i = 1 To UBound(ar, 2)
              Set wsD = Sheets(ar(1, i))
              With wsA.[A4].CurrentRegion
                  .AutoFilter 22, ar(2, i)
                  .Offset(1).EntireRow.Copy wsD.Range("A" & Rows.Count).End(3)(2)
                  '.Offset(1).EntireRow.Delete
                  .AutoFilter
                  wsD.Columns.AutoFit
              End With
         Next i
      
Application.ScreenUpdating = True
MsgBox "All done!", vbExclamation

End Sub

[/CODE]

You'll note that this line of code:-

'.Offset(1).EntireRow.Delete

has an apostrophe in front of it. If you wish to delete the relevant rows of data from the "Active" sheet once a data transfer is completed, then just remove the apostrophe from the line of code. The apostrophe simply de-activates the line of code.

I'm assuming that you have headings in Row 4 of each destination sheet hence the data will be pasted starting in Row 5.
I'm also assuming that your worksheet tab names do not have any trailing or leading spaces or spaces before and after the '-' symbol.

I hope that this helps.

Cheerio,
vcoolio.

 

[vcoolio]

BTW JHP, I'm also assuming that data in the "Active" sheet starts in Row 5 with headings in Row4 as well.

Cheerio,
vcoolio.

 

[jhenryp]

Sorry, I am trying to assign this to a button and it doesn't seem to run properly. I highlighted some detail in color below which errors out. I created a macro associated with the a button using this code. Could you help?


Sub Button2_Click()

Dim wsA As Worksheet, wsD As Worksheet
Dim ar As Variant, i As Integer
Set wsA = Sheets("Active")
ar = [{"Post Adoption-Approved","Post Adoption-Trial Period","Denied";"Approved","Trial","Denied"}]

Application.ScreenUpdating = False

For i = 1 To UBound(ar, 2)
Set wsD = Sheets(ar(1, i))
With wsA.[A4].CurrentRegion
.AutoFilter 22, ar(2, i)
.Offset(1).EntireRow.Copy wsD.Range("A" & Rows.Count).End(3)(2)
.Offset(1).EntireRow.Delete
.AutoFilter
wsD.Columns.AutoFit
End With
Next i

Application.ScreenUpdating = True
MsgBox "All done!", vbExclamation

End Sub

 

[vcoolio]

Hello JHP,

I would say that the problem may be as a result of what I mentioned in post #4 about leading/trailing spaces. Please check this as the sheet names and the sheet names in the array need to be exactly the same; i.e. all spelling, punctuation etc.

I've attached a mock-up of what I assume your workbook to look like. Click on the button in the Active sheet to see it work:-

JHP Sample

Cheerio,
vcoolio.

 

[jhenryp]

Thx vcoolio. When data is transferred to other worksheets, the column size changes in those worksheets. Could you provide insight into how I can keep those column sizes fixed with the data transfer?

You are a big help here.

 

[vcoolio]

Perhaps remove this line of code:-

wsD.Columns.AutoFit

This autofits the column widths of the destination sheets automatically.

Cheerio,
vcoolio.

 

[jhenryp]

I am running into issues here. When I run the code, data is transferred to new worksheet but it duplicates the first few rows of headers first. And it turns off filter on initail "active" worksheet. I can share file with you. I would really appreciate your help.