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

Genheebles

New Member
Joined
Aug 23, 2021
Messages
3
Office Version
  1. 365
Platform
  1. Windows
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


VBA Code:
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
 

Excel Facts

Links? Where??
If Excel says you have links but you can't find them, go to Formulas, Name Manager. Look for old links to dead workbooks & delete.
Hi & welcome to MrExcel.
How about
VBA Code:
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
 
Upvote 0
Solution
Hi & welcome to MrExcel.
How about
VBA Code:
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
 
Upvote 0
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
 
Upvote 0
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 :)
 
Upvote 0
You're welcome & thanks for the feedback.
 
Upvote 0
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.
 
Upvote 0
You already have a thread running for this, so please stick to it. See Rule#12 about duplicate posts.
 
Upvote 0

Forum statistics

Threads
1,213,491
Messages
6,113,963
Members
448,536
Latest member
CantExcel123

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top