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

BEDF002	Bedford Borough Council	Katie	19-Nov-17	13-Nov-17	Adam	0.75	14.96		11.22
BEDF002	Bedford Borough Council	Diana	19-Nov-17	14-Nov-17	Adam	0.75	14.96		11.22
BEDF002	Bedford Borough Council	Katie	19-Nov-17	15-Nov-17	Adam	0.75	14.96		11.22
						5.25			78.99
BEDF002	Bedford Borough Council	Josephine	19-Nov-17	13-Nov-17	Alaco	0.50	14.96		7.48
BEDF002	Bedford Borough Council	Katie	19-Nov-17	14-Nov-17	Alaco	0.50	14.96		7.48
BEDF002	Bedford Borough Council	Josephine	19-Nov-17	15-Nov-17	Alaco	0.50	14.96		7.48
						3.00			45.03
BEDF002	Bedford Borough Council	Claudia	19-Nov-17	14-Nov-17	Beatrice	0.50	14.96		7.48
BEDF002	Bedford Borough Council	Claudia	19-Nov-17	15-Nov-17	Beatrice	0.50	14.96		7.48
BEDF002	Bedford Borough Council	Claudia	19-Nov-17	16-Nov-17	Beatrice	0.50	14.96		7.48
Thanks Marc						1.50			22.44

<tbody>
</tbody>

 

[Jon von der Heyden]

You're welcome!

 

[marcidee]

Thank you for your response - the code breaks at - Set ws = ThisWorkbook.Sheets("Sheet1") - the sheet is named Sheet1 ?

 

[marcidee]

Hi Jon - sorry I had to leave yesterday morning and this is my first time back in front of PC - the code worked yesterday when I tried it but now it breaks as

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 - can see your not but not sure what you are referring to

Strange that it worked first time?

 

[mrshl9898]

Strange ("Sheet1") works for Jons solution but not mine.

Try this:

Sub createnewandmove()


Dim rownum As Long
Dim rownum2 As Long


rownum = 2


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


rownum2 = rownum


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


Loop

On Error Resume Next
ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)).Name = sheetname
Sheets("Sheet1").Rows(rownum & ":" & rownum2).Copy Sheets(sheetname).Range("A1")
rownum = rownum2 + 1


Loop




End Sub

 

[marcidee]

This has created tabs with the names from column F of the original sheet but with no data - it also creates several Sheets with no names after each named one

 

[mrshl9898]

Where is your data located on Sheet1?

 

[marcidee]

This all located on one sheet but numerous people divided into 4 weeks of information example below is adam 3 weeks - data starts on Row 2

BEDF002	Bedford Borough Council	Dee Adams	29-Oct-17	25-Oct-17	Adam	0.75	14.96		11.22
BEDF002	Bedford Borough Council	Dee Adams	29-Oct-17	26-Oct-17	Adam	0.75	14.96		11.22
BEDF002	Bedford Borough Council	Dee Adams	29-Oct-17	27-Oct-17	Adam	0.75	14.96		11.22
BEDF002	Bedford Borough Council	Emma Hutchinson	29-Oct-17	29-Oct-17	Adam	0.75	15.26		11.45
						3.00			45.11
BEDF002	Bedford Borough Council	Sheena Campbell	05-Nov-17	30-Oct-17	Adam	0.75	14.96		11.22
BEDF002	Bedford Borough Council	Diana Talpis	05-Nov-17	31-Oct-17	Adam	0.50	14.96		7.48
BEDF002	Bedford Borough Council	Katie Rowland	05-Nov-17	01-Nov-17	Adam	0.75	14.96		11.22
BEDF002	Bedford Borough Council	Sheena Campbell	05-Nov-17	02-Nov-17	Adam	0.75	14.96		11.22
BEDF002	Bedford Borough Council	Katie Rowland	05-Nov-17	03-Nov-17	Adam	0.75	14.96		11.22
						3.50			52.36
BEDF002	Bedford Borough Council	Katie Rowland	12-Nov-17	06-Nov-17	Adam	0.75	14.96		11.22
BEDF002	Bedford Borough Council	Emma Hutchinson	12-Nov-17	07-Nov-17	Adam	0.75	14.96		11.22
BEDF002	Bedford Borough Council	Katie Rowland	12-Nov-17	08-Nov-17	Adam	0.75	14.96		11.22
BEDF002	Bedford Borough Council	Emma Hutchinson	12-Nov-17	09-Nov-17	Adam	0.75	14.96		11.22
BEDF002	Bedford Borough Council	Katie Rowland	12-Nov-17	10-Nov-17	Adam	0.75	14.96		11.22
BEDF002	Bedford Borough Council	Cherril Ward	12-Nov-17	11-Nov-17	Adam	0.75	15.26		11.45
BEDF002	Bedford Borough Council	Katie Rowland	12-Nov-17	12-Nov-17	Adam	0.75	15.26		11.45
						5.25			78.99

<tbody>
</tbody>

 

[mrshl9898]

I can't seem to break this:

Will keep adding data to the sheets. If the sheet doesn't exist it will create it.

Sub createnewandmove()


Dim rownum As Long
Dim rownum2 As Long
    Dim worksh As Integer
    Dim worksheetexists As Boolean
    


rownum = 2


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


rownum2 = rownum


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






    worksh = Application.Sheets.Count
    worksheetexists = False
    For x = 1 To worksh
        If Worksheets(x).Name = sheetname Then
            worksheetexists = True
            Exit For
        End If
    Next x
    If worksheetexists = False Then
    ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)).Name = sheetname
    End If
   
Sheets("Sheet1").Rows(rownum & ":" & rownum2).Copy Sheets(sheetname).Rows(Sheets(sheetname).Cells(Sheets(sheetname).Rows.Count, 7).End(xlUp).Offset(1, 0).Row)
rownum = rownum2 + 1
Loop


End Sub

 

[marcidee]

Thank you for your help with this - this now breaks at this point - One tab is created but no data

Sheets("Sheet1").Rows(rownum & ":" & rownum2).Copy Sheets(sheetname).Rows(Sheets(sheetname).Cells(Sheets(sheetname).Rows.Count, 7).End(xlUp).Offset(1, 0).Row)
rownum = rownum2 + 1

 

[mrshl9898]

What version of Excel are you using?

Try:

Sub createnewandmove()

Dim rownum As Long
Dim rownum2 As Long
    Dim worksh As Integer
    Dim worksheetexists As Boolean
    


rownum = 2


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


rownum2 = rownum


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






    worksh = Application.Sheets.Count
    worksheetexists = False
    For x = 1 To worksh
        If Worksheets(x).Name = sheetname Then
            worksheetexists = True
            Exit For
        End If
    Next x
    If worksheetexists = False Then
    ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)).Name = sheetname
    End If
   
Sheets("Sheet1").Rows(rownum & ":" & rownum2).Copy
Sheets(sheetname).Select
Sheets(sheetname).Rows(Sheets(sheetname).Cells(Sheets(sheetname).Rows.Count, 7).End(xlUp).Offset(1, 0).Row).PasteSpecial xlPasteValues
rownum = rownum2 + 1
Loop


End Sub