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]

Do the sheets have the same name as the values in column D?

 

[sbrown64]

column D is the company name, so it will vary all the time.

 

[Fluff]

Yes, but do the sheets the data needs to be copied have the same name as the company?
So if you had MrExcel in column D, would there be a sheet called MrExcel?

 

[sbrown64]

ideally that would be good

 

[Fluff]

Do the sheets for each company already exist?

 

[sbrown64]

not yet, just sheet 1 and 2

 

[Fluff]

Ok, try this

Sub sbrown64()
   Dim Cl As Range
   Dim Ky As Variant
   Dim Ws As Worksheet
   
   Set Ws = Sheets(1)
   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

 

[sbrown64]

it auto created a sheet 2 and came up with this error message

[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]Sub sbrown64()
Dim Cl As Range
Dim Ky As Variant
Dim Ws As Worksheet

Set Ws = Sheets(1)
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
[/FONT]
run time error 1004 also no data was copied

 

[Fluff]

What was the error message?