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]

 

[sbrown64]

run time error 1004
application-defined or object defined error

also the sheet was empty, no data was copied across

 

[Fluff]

What is the name of the sheet containing your data?

 

[sbrown64]

it is called TEST2

 

[sbrown64]

Sorry the workbook is called TEST2
The sheets at the moment are called Sheet 1, BD and Cannon

 

[sbrown64]

if I run this code, the data copies to the Cannon sheet

 

[sbrown64]

Sub Copy_Cannon()
Application.ScreenUpdating = False
Dim i As Integer
Dim Lastrow As Long
Dim Lastrowa As Long
Sheets(1).Activate
Lastrow = Cells(Rows.Count, "F").End(xlUp).Row
Lastrowa = Sheets(2).Cells(Rows.Count, "F").End(xlUp).Row + 1
For i = 1 To Lastrow
If Cells(i, 4).Value = "Cannon" Then
Rows(i).Copy Destination:=Sheets(3).Rows(Lastrowa)
Lastrowa = Lastrowa + 1
End If
Next
Cells(1, 1).Select
Application.ScreenUpdating = True
End Sub

 

[sbrown64]

hello again

I have just copied the code underneath the original code and changed Cannon to Bd and it seams to work?

[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]Sub Copy_Cannon()
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 = "Cannon" Then
Rows(i).Copy Destination:=Sheets(3).Rows(Lastrowa)
Lastrowa = Lastrowa + 1
End If
Next
Cells(1, 1).Select
Application.ScreenUpdating = True
End Sub[/FONT]
[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]

 

[sbrown64]

just noticed that now running it (2 times) the Cannon data was copied across twice but not the Bd, also I only know how to run it from going into the code and clicking the run button

 

[Fluff]

How about

Sub sbrown64()
   Dim Cl As Range
   Dim Ky As Variant
   Dim Ws As Worksheet
   
   Set Ws = Sheets("[COLOR=#ff0000]sheet1[/COLOR]")
   With CreateObject("Scripting.dictionary")
      .CompareMode = vbTextCompare
      For Each Cl In Ws.Range("D2", Ws.Range("D" & Rows.Count).End(xlUp))
         .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

Value in red must match the name of the sheet with the data.
Also remove any sheet that are already named with the company name, or you will get further errors.

 

[sbrown64]

this line appeared in yellow when i ran it
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif] Sheets.Add(, Sheets(1)).Name = Ky

Again no data was copied to the new sheet
[/FONT]