copying cells from sheet 1 to various other sheets

[sbrown64]

Hi

I have a spreadsheet which has over 1000 lines, all for varying companies. What I would like to do is create an option so when you run it, it will copy the relevant lines to their respective sheet. The code listed below is some I have seen on here, which works to a point. It will run for one company, bit if I press run again it adds the same ones' to sheet 2. The other point is how to make it do if for ALL companies and not just the one? I hope you can help.

Regards

Stephen

[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]Sub Copy_Bd()
Application.ScreenUpdating = False
Dim i As Integer
Dim Lastrow As Long
Dim Lastrowa As Long[/FONT]
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]Sheets(1).Activate
Lastrow = Cells(Rows.Count, "F").End(xlUp).Row
Lastrowa = Sheets(2).Cells(Rows.Count, "F").End(xlUp).Row + 1[/FONT]
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif] For i = 1 To Lastrow
If Cells(i, 4).Value = "Bd" Then
Rows(i).Copy Destination:=Sheets(2).Rows(Lastrowa)
Lastrowa = Lastrowa + 1
End If
Next
Cells(1, 1).Select
Application.ScreenUpdating = True
End Sub[/FONT]

 

[Fluff]

What was the error message?

 

[sbrown64]

run time error 1004
application-defined or object defined error

also the sheet was empty, no data was copied across​

 

[Fluff]

That suggests that is no data in Col D on "Sheet1"
Did you make sure that the sheet name I highlighted in red is looking at the correct sheet?

 

[sbrown64]

Sheet 1 is the name and column D has all the company names

[TABLE="width: 59"]
<colgroup><col></colgroup><tbody>[TR]
[TD]Bd[/TD]
[/TR]
[TR]
[TD]Bd[/TD]
[/TR]
[TR]
[TD] [/TD]
[/TR]
[TR]
[TD]Cannon[/TD]
[/TR]
[TR]
[TD]LY[/TD]
[/TR]
[TR]
[TD]Cannon[/TD]
[/TR]
[TR]
[TD]Bd[/TD]
[/TR]
[TR]
[TD]Cannon[/TD]
[/TR]
[TR]
[TD]TSP[/TD]
[/TR]
[TR]
[TD]NHDC[/TD]
[/TR]
[TR]
[TD]Bd[/TD]
[/TR]
[TR]
[TD]Bd[/TD]
[/TR]
[TR]
[TD]NHDC[/TD]
[/TR]
[TR]
[TD]NHDC[/TD]
[/TR]
[TR]
[TD]Bd[/TD]
[/TR]
[TR]
[TD]Bd[/TD]
[/TR]
[TR]
[TD]Bd[/TD]
[/TR]
[TR]
[TD]Bd[/TD]
[/TR]
[TR]
[TD] [/TD]
[/TR]
[TR]
[TD]Bd[/TD]
[/TR]
[TR]
[TD]LY [/TD]
[/TR]
[TR]
[TD]Bd[/TD]
[/TR]
[TR]
[TD]Cannon[/TD]
[/TR]
[TR]
[TD]Bd[/TD]
[/TR]
[TR]
[TD]Bd[/TD]
[/TR]
[TR]
[TD]Cannon[/TD]
[/TR]
[TR]
[TD]Bd[/TD]
[/TR]
</tbody>[/TABLE]

 

[Fluff]

Does the tab show "Sheet1" or "Sheet 1"?

 

[sbrown64]

The original tab says Sheet1, it then creates a Sheet2 but is empty.

 

[Fluff]

Do you have blank cells in col D?
If so try

Sub sbrown64()
   Dim Cl As Range
   Dim Ky As Variant
   Dim Ws As Worksheet
   
   Set Ws = Sheets("sheet1")
   With CreateObject("Scripting.dictionary")
      .CompareMode = vbTextCompare
      For Each Cl In Ws.Range("D2", Ws.Range("D" & Rows.Count).End(xlUp))
         If Cl.Value <> "" Then .item(Cl.Value) = Empty
      Next Cl
      For Each Ky In .Keys
         Sheets.Add(, Sheets(1)).Name = Ky
         Ws.Range("A1:D1").AutoFilter 4, Ky
         Ws.AutoFilter.Range.EntireRow.Copy Sheets(Ky).Range("A1")
      Next Ky
   End With
   Ws.AutoFilterMode = False
End Sub

 

[sbrown64]

run time error 1004

cannot rename a sheet to the same name as another sheet, a referenced object library or a workbook referenced in VB.

 

[Fluff]

You said the other sheets didn't exist.
What do you want to happen if the other sheets already exist?

 

[sbrown64]

Hi

I have just deleted all the pages except the main page and re-run the code and it has created a page for all companies, however without any headers, it has created a separate page called Company with headers. If i then run the code a second time it comes up with the error message and creates a blank page.

How do i run it more than once to update the pages as more data is entered?

update
just realised one of the companies has had two pages created with the same data?