Copy an entire row from one sheet to another based on a cell's value

[eccles291]

Hello,

Please help me from going totally insane! I'm not hugely experienced with Excel and have no idea about VLookups, Macros or VBA but I've been hunting for the answer to my problem for hours and hours with no success!!

I have a spreadsheet for our small building company where I want to keep track of all our purchases but also be able to detail what's been bought for each separate job that we're doing as we have a few sites on the go at once. I have one workbook with several sheets on it. Sheet 1 is "Total Purchases" which is where I'll enter the data and each separate job has it's own named sheet within the workbook. eg - sheet 2 is: "Anvil Cottage 001" , sheet 3 is "35 The Leys 002" , sheet 4 is "PFB 003" etc. The incremented numbers 001, 002, 003 are our job reference number which is used to identify them on the "Total Purchases" sheet in column E.

From trawling through this site, and many others, I've found and tried to adapt a Macro that will look down column E on the "Total Purchases" sheet and wherever it finds "001" it then copies that entire row to the "Anvil Cottage 001" sheet. When it finds "002" in column E it copies that entire row to "35 The Leys 002" sheet and so on. Hopefully this makes sense.

What doesn't seem to work is the Macro that I've tried to use. I've only done it for the "Anvil Cottage 001" sheet so far, and I'm sure I'll have to use a similar Macro on each sheet (with the corresponding details in the macro for each different job name) but this first one is not working. This is the Macro I've got:


Sub CopyRow()
Application.ScreenUpdating = False
Dim LastRow As Long
LastRow = Sheets("Total Purchases").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Dim x As Long
x = 3
Dim rng As Range
For Each rng In Sheets("Total Purchases").Range("E3:E" & LastRow)
If rng = "001" Then
rng.EntireRow.Copy
Sheets("Anvil Cottage 001").Cells(x, 1).PasteSpecial xlPasteValues
x = x + 1
End If
Next rng
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub




Where is it going wrong?! I'm using Excel for Mac 2016 (Version 16.16.3) if that makes much difference.

Thank you so much.

ray:

 

[eccles291]

Thanks again for your help with this. Sorry I've not been back to reply for a couple of days, I've been out on site and not in the office since Tuesday.

I put that macro in which does work but the only thing is, when I enter new data on the "Total Purchases" sheet and run the macro again to pick up that data on the individual sheets, it repeats all the info and inserts it all again underneath the original lot. The only solution I can think of is to delete everything on the sheet before running the macro again. Is this a limitation of a macro? If it is, it's not the end of the world but in the months to come, once there's a lot of info on the sheet, it could become a bit tricky & tedious.

 

[Fluff]

Untested, but this should clear the "Jobs" sheets before copying anything over.

Sub CopyRow()
   Application.ScreenUpdating = False
   Dim LastRow As Long
   Dim fnd As Range, rng As Range, Lst As Range
   
   Set Lst = Sheets("List").Range("A1").CurrentRegion
   LastRow = Sheets("Total Purchases").Cells.find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

   For Each rng In Lst.Offset(, 1)
      Sheets(rng.Value).UsedRange.Offset(1).ClearContents
   Next rng

   For Each rng In Sheets("Total Purchases").Range("E3:E" & LastRow)
      Set fnd = Lst.find(rng.Value, , , xlWhole, , , False, , False)
      If Not fnd Is Nothing Then
         rng.EntireRow.Copy
         Sheets(fnd.Offset(, 1).Value).Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial xlPasteValues
      End If
   Next rng
   Application.CutCopyMode = False
   Application.ScreenUpdating = True
End Sub

 

[eccles291]

Thanks again. . I'm back in the office again today so finally had chance to try the updated macro. When I changed it the following message appeared...

Run-time error '9':
Subscript out of range

When I clicked on the "Debug" button it highlighted this line:

Sheets(rng.Value).UsedRange.Offset(1).ClearContents

 

[Fluff]

Oops, this line

Set Lst = Sheets("List").Range("A1").CurrentRegion

should be

   With Sheets("List").Range("A1").CurrentRegion
      Set Lst = .Offset(1).Resize(.Rows.Count - 1)
   End With

 

[eccles291]

Oops, this line

Set Lst = Sheets("List").Range("A1").CurrentRegion

should be

   With Sheets("List").Range("A1").CurrentRegion
      Set Lst = .Offset(1).Resize(.Rows.Count - 1)
   End With

I've amended that line but it still throws up the exact same error message as before with the Debug button also highlighting the same line as it previously did.

 

[Fluff]

The error is telling you that the sheet does not exist.
Do you have any blanks in column B?
Also you need to ensure that all the column B values are exactly the same as the sheet names.