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 row has you headers?

 

[sbrown64]

rows 1 - 4 are names and headers

 

[Fluff]

Ok, how about

Sub sbrown64()
   Dim Cl As Range
   Dim Ky As Variant
   Dim Ws As Worksheet
   Dim UsdRws As Long
   
   Set Ws = Sheets("sheet1")
   UsdRws = Ws.Range("D" & Rows.Count).End(xlUp).Row
   With CreateObject("Scripting.dictionary")
      .CompareMode = vbTextCompare
      For Each Cl In Ws.Range("D5:D" & UsdRws)
         If Cl.Value <> "" Then .item(Cl.Value) = Empty
      Next Cl
      For Each Ky In .Keys
         Ws.Range("A4:D" & UsdRws).AutoFilter 4, Ky
         If Not Evaluate("isref('" & Ky & "'!A1)") Then
            Sheets.Add(, Sheets(1)).Name = Ky
            Ws.Range("A1:A" & UsdRws).EntireRow.Copy Sheets(Ky).Range("A1")
         Else
            Ws.Range("A5:A" & UsdRws).EntireRow.Copy Sheets(Ky).Range("D" & Rows.Count).End(xlUp).Offset(1, -3)
         End If
      Next Ky
   End With
   Ws.AutoFilterMode = False
End Sub

 

[Fluff]

Just noticed your edit to post#30, so try this instead

Sub sbrown64()
   Dim Cl As Range
   Dim Ky As Variant
   Dim Ws As Worksheet
   Dim UsdRws As Long
   
   Set Ws = Sheets("sheet1")
   UsdRws = Ws.Range("D" & Rows.Count).End(xlUp).Row
   With CreateObject("Scripting.dictionary")
      .CompareMode = vbTextCompare
      For Each Cl In Ws.Range("D5:D" & UsdRws)
         If Cl.Value <> "" Then .item(Trim(Cl.Value)) = Empty
      Next Cl
      For Each Ky In .Keys
         Ws.Range("A4:D" & UsdRws).AutoFilter 4, Ky
         If Not Evaluate("isref('" & Ky & "'!A1)") Then
            Sheets.Add(, Sheets(1)).Name = Ky
            Ws.Range("A1:A" & UsdRws).EntireRow.Copy Sheets(Ky).Range("A1")
         Else
            Ws.Range("A5:A" & UsdRws).EntireRow.Copy Sheets(Ky).Range("D" & Rows.Count).End(xlUp).Offset(1, -3)
         End If
      Next Ky
   End With
   Ws.AutoFilterMode = False
End Sub

 

[sbrown64]

Hi

Just ran the new code and it worked, all the data copied to their own sheets. I then went to the major sheet and tried entering a new line with a new company and ran the code and it created a new page with the data, however I noticed one of the other companies had now double info (duplicated)

 

[Fluff]

Will you be adding new rows to the Master sheet, or will you be replacing it with new data?
If the former, are you happy to delete the info on the company sheets & then copy all the data over again?

 

[sbrown64]

the master sheet will be an going sheet. The one we are working on is a one page spreadsheet with 30 entries, the original has approx. 1000 lines with about 60 companies involved.

 

[sbrown64]

just sent you a pm with a link to the original

 

[Fluff]

Can you please post the link to the thread, as per forum rules
Thanks

 

[sbrown64]

https://1drv.ms/x/s!Aq3WqOz73fYygYUSFq-yDZp60mP7EQ?e=5w5KqC

I should point out that it is a fluid sheet, that over time will have new companies and new lines added.

Regards

Stephen