Copy Data to a new tab same sheet

M

marcidee

Board Regular
Joined
May 23, 2016
Messages
196
Office Version
  1. 2019
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]
 
Sort by date Sort by votes

Excel Facts

Workdays for a market open Mon, Wed, Friday?
Yes! Use "0101011" for the weekend argument in NETWORKDAYS.INTL or WORKDAY.INTL. The 7 digits start on Monday. 1 means it is a weekend.
Thank you for your response - the code breaks at - Set ws = ThisWorkbook.Sheets("Sheet1") - the sheet is named Sheet1 ?
 
Upvote 0
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?
 
Upvote 0
Strange ("Sheet1") works for Jons solution but not mine.

Try this:

Code: 
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
 
Last edited:
Upvote 0
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
 
Upvote 0
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

[TABLE="width: 791"]
<tbody>[TR]
[TD]BEDF002
[/TD]
[TD]Bedford Borough Council
[/TD]
[TD]Dee Adams
[/TD]
[TD="align: right"]29-Oct-17
[/TD]
[TD]25-Oct-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]Dee Adams
[/TD]
[TD="align: right"]29-Oct-17
[/TD]
[TD]26-Oct-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]Dee Adams
[/TD]
[TD="align: right"]29-Oct-17
[/TD]
[TD]27-Oct-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]Emma Hutchinson
[/TD]
[TD="align: right"]29-Oct-17
[/TD]
[TD]29-Oct-17
[/TD]
[TD]Adam
[/TD]
[TD]0.75
[/TD]
[TD="align: right"]15.26
[/TD]
[TD][/TD]
[TD]11.45
[/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.11
[/TD]
[/TR]
[TR]
[TD]BEDF002
[/TD]
[TD]Bedford Borough Council
[/TD]
[TD]Sheena Campbell
[/TD]
[TD="align: right"]05-Nov-17
[/TD]
[TD]30-Oct-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 Talpis
[/TD]
[TD="align: right"]05-Nov-17
[/TD]
[TD]31-Oct-17
[/TD]
[TD]Adam
[/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 Rowland
[/TD]
[TD="align: right"]05-Nov-17
[/TD]
[TD]01-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]Sheena Campbell
[/TD]
[TD="align: right"]05-Nov-17
[/TD]
[TD]02-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 Rowland
[/TD]
[TD="align: right"]05-Nov-17
[/TD]
[TD]03-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]3.50
[/TD]
[TD][/TD]
[TD][/TD]
[TD]52.36
[/TD]
[/TR]
[TR]
[TD]BEDF002
[/TD]
[TD]Bedford Borough Council
[/TD]
[TD]Katie Rowland
[/TD]
[TD="align: right"]12-Nov-17
[/TD]
[TD]06-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]Emma Hutchinson
[/TD]
[TD="align: right"]12-Nov-17
[/TD]
[TD]07-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 Rowland
[/TD]
[TD="align: right"]12-Nov-17
[/TD]
[TD]08-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]Emma Hutchinson
[/TD]
[TD="align: right"]12-Nov-17
[/TD]
[TD]09-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 Rowland
[/TD]
[TD="align: right"]12-Nov-17
[/TD]
[TD]10-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]Cherril Ward
[/TD]
[TD="align: right"]12-Nov-17
[/TD]
[TD]11-Nov-17
[/TD]
[TD]Adam
[/TD]
[TD]0.75
[/TD]
[TD="align: right"]15.26
[/TD]
[TD][/TD]
[TD]11.45
[/TD]
[/TR]
[TR]
[TD]BEDF002
[/TD]
[TD]Bedford Borough Council
[/TD]
[TD]Katie Rowland
[/TD]
[TD="align: right"]12-Nov-17
[/TD]
[TD]12-Nov-17
[/TD]
[TD]Adam
[/TD]
[TD]0.75
[/TD]
[TD="align: right"]15.26
[/TD]
[TD][/TD]
[TD]11.45
[/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]
</tbody>[/TABLE]
 
Last edited:
Upvote 0
I can't seem to break this:

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

Code: 
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
 
Upvote 0
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
 
Upvote 0
What version of Excel are you using?

Try:

Code: 
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
 
Upvote 0
You must log in or register to reply here.

Forum statistics

Threads
1,223,911
Messages
6,175,337
Members
452,637
Latest member
Ezio2866

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top