VBA Code for Automatically moving rows to other sheets in a workbook based on cell values in a column

[Genheebles]

I am hoping someone can assist me with this question. I have attempted to construct code to attach to a sheet in my excel workbook based on information I have gleaned from internet searches and forums .

What I am trying to achieve is for the sheet to automatically place a copy of a row from an entry sheet across to various other sheets in the workbook dependent on the cell text of column E. Ideally, I would like it to also leave a copy on the entry sheet.

The data is being entered into a sheet called 'Form'. The column into which the dependent text is being entered into is Column E. The dependent text is the same as the names of the other sheets in the workbook and these are represented within the following coding which I have attached to the 'Form Sheet'.

I want the formula to copy and paste the row from the 'Form' Sheet into the sheet of its same name positioned on the next available row. The row commences from column A.

Please don't laugh at my attempt..... I would be grateful for any assistance with where I have gone wrong with this.

Thanks
Genheebles

Private Sub Worksheet_MoveRow()

If Not Intersect(Target, Range("E:E")) Is Nothing Then
If Target.Cells.Count > 1 Or IsEmpty(Target) Then Exit Sub
Dim Lastrow As Long
Lastrow = Sheets("Noble Park Office").Cells(Rows.Count, "A").End(xlUp).Row + 1

If Target.Value = "Noble Park Office" Then
Rows(Target.Row).Copy Destination:=Sheets("Noble Park Office").Rows(Lastrow)
Rows(Target.Row).Delete

If Not Intersect(Target, Range("E:E")) Is Nothing Then
If Target.Cells.Count > 1 Or IsEmpty(Target) Then Exit Sub
Dim Lastrow As Long
Lastrow = Sheets("Morwell Office").Cells(Rows.Count, "A").End(xlUp).Row + 1

If Target.Value = "Morwell Office" Then
Rows(Target.Row).Copy Destination:=Sheets("Morwell Office").Rows(Lastrow)
Rows(Target.Row).Delete

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

If Target.Value = "East" Then
Rows(Target.Row).Copy Destination:=Sheets("East").Rows(Lastrow)

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

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

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

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

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

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

If Not Intersect(Target, Range("E:E")) Is Nothing Then
If Target.Cells.Count > 1 Or IsEmpty(Target) Then Exit Sub
Dim Lastrow As Long
Lastrow = Sheets("Manchester").Cells(Rows.Count, "A").End(xlUp).Row + 1
Noble Par
If Target.Value = "Manchester" Then
Rows(Target.Row).Copy Destination:=Sheets("Manchester").Rows(Lastrow)
Rows(Target.Row).Delete

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

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

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

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

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

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

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

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

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

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

If Not Intersect(Target, Range("E:E")) Is Nothing Then
If Target.Cells.Count > 1 Or IsEmpty(Target) Then Exit Sub
Dim Lastrow As Long
Lastrow = Sheets("Wy Yung").Cells(Rows.Count, "A").End(xlUp).Row + 1

If Target.Value = "Wy Yung" Then
Rows(Target.Row).Copy Destination:=Sheets("Wy Yung").Rows(Lastrow)
Rows(Target.Row).Delete

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

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

 

[Fluff]

Hi & welcome to MrExcel.
How about

Private Sub Worksheet_Change(ByVal Target As Range)
   If Target.CountLarge > 1 Or IsEmpty(Target) Then Exit Sub
   If Not Intersect(Target, Range("E:E")) Is Nothing Then
      If Evaluate("isref('" & Target.Value & "'!A1)") Then
         Target.EntireRow.Copy Sheets(Target.Value).Range("A" & Rows.Count).End(xlUp).Offset(1)
      Else
         MsgBox "No sheet exists for " & Target.Value
      End If
   End If
End Sub

 

[Genheebles]

Hi & welcome to MrExcel.
How about

Private Sub Worksheet_Change(ByVal Target As Range)
   If Target.CountLarge > 1 Or IsEmpty(Target) Then Exit Sub
   If Not Intersect(Target, Range("E:E")) Is Nothing Then
      If Evaluate("isref('" & Target.Value & "'!A1)") Then
         Target.EntireRow.Copy Sheets(Target.Value).Range("A" & Rows.Count).End(xlUp).Offset(1)
      Else
         MsgBox "No sheet exists for " & Target.Value
      End If
   End If
End Sub

Hey thanks for responding. I will paste this into the code panel and see what I can work out. Which bits do I need to change to reflect my spreadsheet variables? Also, what do I need to do to apply this code so that it knows to send the row to the sheet of the same name as the cell criteria in column E? Do I just repeat the code with the new cell criteria and destination sheet defined? Sorry, I am very new at this and I don't generally think in a coding way

 

[Fluff]

You don't need to change anything, just copy/paste the code into the Form sheets code module.
It will run automatically if you change a single cell in col E

 

[Genheebles]

Oh my gosh you are truly amazing!!! Thank you so much... Here I was thinking I had to do something with it. I am eternally grateful

 

[Fluff]

You're welcome & thanks for the feedback.

 

[MilkyWay1]

You don't need to change anything, just copy/paste the code into the Form sheets code module.
It will run automatically if you change a single cell in col E

This worked for me but it overwrites the row copied each time I make a new entry. So I only ever have the latest row copied instead of a list of all copied rows.

 

[Fluff]

You already have a thread running for this, so please stick to it. See Rule#12 about duplicate posts.