Copy Data to a new tab same sheet

[marcidee]

I have a sheet that I need to send to a client each month - they require each person as seen in column F (Adam , Alaco) in a new tab in the same spreadsheet (there are numerous names in the one sheet) - so in the example below all the data for Adam will go into one sheet, all the data for Alaco will go into the next sheet and Beatrice in the next sheet and so on (same file).


Is there a script that will create a new tab for each person in column F and copy or move the data into that sheet.

If you can help I would be very grateful
[TABLE="width: 791"]
<tbody>[TR]
[TD]BEDF002
[/TD]
[TD]Bedford Borough Council
[/TD]
[TD]Katie
[/TD]
[TD="align: right"]19-Nov-17
[/TD]
[TD]13-Nov-17
[/TD]
[TD]Adam
[/TD]
[TD]0.75
[/TD]
[TD="align: right"]14.96
[/TD]
[TD][/TD]
[TD]11.22
[/TD]
[/TR]
[TR]
[TD]BEDF002
[/TD]
[TD]Bedford Borough Council
[/TD]
[TD]Diana
[/TD]
[TD="align: right"]19-Nov-17
[/TD]
[TD]14-Nov-17
[/TD]
[TD]Adam
[/TD]
[TD]0.75
[/TD]
[TD="align: right"]14.96
[/TD]
[TD][/TD]
[TD]11.22
[/TD]
[/TR]
[TR]
[TD]BEDF002
[/TD]
[TD]Bedford Borough Council
[/TD]
[TD]Katie
[/TD]
[TD="align: right"]19-Nov-17
[/TD]
[TD]15-Nov-17
[/TD]
[TD]Adam
[/TD]
[TD]0.75
[/TD]
[TD="align: right"]14.96
[/TD]
[TD][/TD]
[TD]11.22
[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]5.25
[/TD]
[TD][/TD]
[TD][/TD]
[TD]78.99
[/TD]
[/TR]
[TR]
[TD]BEDF002
[/TD]
[TD]Bedford Borough Council
[/TD]
[TD]Josephine
[/TD]
[TD="align: right"]19-Nov-17
[/TD]
[TD]13-Nov-17
[/TD]
[TD]Alaco
[/TD]
[TD]0.50
[/TD]
[TD="align: right"]14.96
[/TD]
[TD][/TD]
[TD]7.48
[/TD]
[/TR]
[TR]
[TD]BEDF002
[/TD]
[TD]Bedford Borough Council
[/TD]
[TD]Katie
[/TD]
[TD="align: right"]19-Nov-17
[/TD]
[TD]14-Nov-17
[/TD]
[TD]Alaco
[/TD]
[TD]0.50
[/TD]
[TD="align: right"]14.96
[/TD]
[TD][/TD]
[TD]7.48
[/TD]
[/TR]
[TR]
[TD]BEDF002
[/TD]
[TD]Bedford Borough Council
[/TD]
[TD]Josephine
[/TD]
[TD="align: right"]19-Nov-17
[/TD]
[TD]15-Nov-17
[/TD]
[TD]Alaco
[/TD]
[TD]0.50
[/TD]
[TD="align: right"]14.96
[/TD]
[TD][/TD]
[TD]7.48
[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]3.00
[/TD]
[TD][/TD]
[TD][/TD]
[TD]45.03
[/TD]
[/TR]
[TR]
[TD]BEDF002
[/TD]
[TD]Bedford Borough Council
[/TD]
[TD]Claudia
[/TD]
[TD="align: right"]19-Nov-17
[/TD]
[TD]14-Nov-17
[/TD]
[TD]Beatrice
[/TD]
[TD]0.50
[/TD]
[TD="align: right"]14.96
[/TD]
[TD][/TD]
[TD]7.48
[/TD]
[/TR]
[TR]
[TD]BEDF002
[/TD]
[TD]Bedford Borough Council
[/TD]
[TD]Claudia
[/TD]
[TD="align: right"]19-Nov-17
[/TD]
[TD]15-Nov-17
[/TD]
[TD]Beatrice
[/TD]
[TD]0.50
[/TD]
[TD="align: right"]14.96
[/TD]
[TD][/TD]
[TD]7.48
[/TD]
[/TR]
[TR]
[TD]BEDF002
[/TD]
[TD]Bedford Borough Council
[/TD]
[TD]Claudia
[/TD]
[TD="align: right"]19-Nov-17
[/TD]
[TD]16-Nov-17
[/TD]
[TD]Beatrice
[/TD]
[TD]0.50
[/TD]
[TD="align: right"]14.96
[/TD]
[TD][/TD]
[TD]7.48
[/TD]
[/TR]
[TR]
[TD]Thanks
Marc
[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]1.50
[/TD]
[TD][/TD]
[TD][/TD]
[TD]22.44


[/TD]
[/TR]
</tbody>[/TABLE]

 

[mrshl9898]

I'm assuming you have headers and the data starts on row2.

Try this, just rename ("Sheet1") to whatever sheet the data is on:

Sub createnewandmove()

Dim rownum As Long
Dim rownum2 As Long
Dim ws As Worksheet


Set ws = ThisWorkbook.Sheets("Sheet1")
rownum = 2

Do Until ws.Cells(rownum, 7).Value = ""

rownum2 = rownum

Do Until ws.Cells(rownum2, 6).Value = ""
rownum2 = rownum2 + 1
lastrow = rownum2
sheetname = ws.Cells(rownum2 - 1, 6).Value

Loop

ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)).Name = sheetname
ws.Rows(rownum & ":" & rownum2).Copy Sheets(sheetname).Range("A1")
rownum = rownum2 + 1

Loop


End Sub

 

[My Aswer Is This]

Try this:
Run this script from the sheet with your current data:

Sub Filter()
'Modified 12-4-17 7:20 PM EST
Application.ScreenUpdating = False
Dim i As Long
Dim b As Long
Dim c As Long
Dim ans As String
Dim Lastrow As Long
Dim Lastrowa As Long
Dim sn As String
sn = ActiveSheet.Name
Lastrow = Sheets(sn).Cells(Rows.Count, "F").End(xlUp).Row
Sheets.Add(After:=Sheets(sn)).Name = "Temp"
Sheets(sn).Range("F2:F" & Lastrow).Copy Sheets("Temp").Range("A1")
Lastrowa = Sheets("Temp").Cells(Rows.Count, "A").End(xlUp).Row
Sheets("Temp").Range("A1:A" & Lastrowa).RemoveDuplicates 1, xlNo
Sheets(sn).Activate
Lastrowa = Sheets("Temp").Cells(Rows.Count, "A").End(xlUp).Row
    For i = 1 To Lastrowa
        Sheets.Add(After:=Sheets("Temp")).Name = Sheets("Temp").Cells(i, 1).Value
    Next
 Sheets(sn).Activate
    For b = 2 To Lastrow
        ans = Cells(b, "F").Value
        Rows(b).Copy Sheets(ans).Rows(Sheets(ans).Cells(Rows.Count, "F").End(xlUp).Row + 1)
    Next
    For c = 3 To Lastrowa + 2
     Sheets(sn).Rows(1).Copy Sheets(c).Rows(1)
    Next
MsgBox "I now need to delete a temp sheet I made. Just click Ok and then Delete"
Sheets("Temp").Delete
Application.ScreenUpdating = True
End Sub

 

[marcidee]

Thank you for your reply - the code is breaking at Set ws = ThisWorkbook.Sheets("Sheet1") saying "can't be executed in break mode"

Will this script create a new sheet (or even copy data to a new sheet) wherever it sees a new name in column F - is this even possible? I assume if it can then we would just need to manually create the new tabs first (could be several)

There are headings and the data starts row 2

 

[My Aswer Is This]

Did you try my script in Post 3 ?

 

[marcidee]

No I hadn't - I have now (thank you) and it breaks at: Sheets.Add(After:=Sheets("Temp")).Name = Sheets("Temp").Cells(i, 1).Value

I can see that it has created a sheet (temp) with all the names in it- has a blank line between the first name and the second name - so not sure if that is the problem - no data has been transfered

 

[My Aswer Is This]

That is because you have one cell in column "F" that is empty or one of those names in column "F" already have a sheet created with this name.

This script creates all the sheets and then copies all the data into those sheets.

I thought that was what you wanted.

Your posting title says:
Copy Data to a new tab same sheet

 

[Jon von der Heyden]

Another option to try:

Public Sub SplitByName()
    Dim lngLastRow      As Long
    Dim rngLead         As Excel.Range
    Dim rngArea         As Excel.Range
    Dim wksNew          As Excel.Worksheet
    
    With Sheets("Sheet1") '<-- this needs to refer to YOUR sheet name
        lngLastRow = .Range("G" & .Rows.Count).End(xlUp).Row
        Set rngLead = .Range("A2:A" & lngLastRow)
    End With
    
    For Each rngArea In rngLead.SpecialCells(xlCellTypeConstants).Areas '<-- I assume that the data in column A is constant, and not formulas
        Set wksNew = ThisWorkbook.Worksheets.Add(After:=rngLead.Parent)
        wksNew.Name = rngArea.Resize(1, 1).Offset(, 5).Text '<-- this could giove a RT error if the name is not valid per sheet name rules
        Call rngLead.Resize(1, 1).Offset(-1).EntireRow.Copy(Destination:=wksNew.Range("A1"))
        Application.CutCopyMode = False
        With rngArea
            Call .Resize(.Rows.Count + 1).EntireRow.Copy(Destination:=wksNew.Range("A2"))
            Application.CutCopyMode = False
        End With
    Next rngArea
End Sub

Please pay attention to the remarks I made in the code.

These results should also include your subtotals.

 

[My Aswer Is This]

Since your not responding back. I'm going to move on and see if there are some questions here that have not been answered. I'm sure there are numerous other ways to do this.

 

[marcidee]

Hi Jon

That look like it may have worked - I will fully test later - tank you so much