New tab when name changes in column A

marcidee

Board Regular
Joined
May 23, 2016
Messages
196
Office Version
  1. 2019
Please can you help with a script.

I have a spreadsheet that goes on for numerous lines - I would like to create a news tab every time there is a name change in Column A - and copy the contents of all columns (B - G) - the name could appear on several rows.

ie in the example below 3 new tabs created - one for each name - the tabs renamed with that person's name and all 6 columns columns copied

Thank you for your help

[TABLE="width: 751"]
<tbody>[TR]
[TD]Abimbola Dunsin (Dunsin) B[/TD]
[TD]1[/TD]
[TD]Thu 08 Aug 2019[/TD]
[TD]Peter Howes[/TD]
[TD="align: right"]0.75[/TD]
[TD]9.00[/TD]
[TD="align: right"]6.75[/TD]
[/TR]
[TR]
[TD]Abimbola Dunsin (Dunsin) B[/TD]
[TD]1[/TD]
[TD]Fri 09 Aug 2019[/TD]
[TD]Peter Howes[/TD]
[TD="align: right"]0.5[/TD]
[TD]9.00[/TD]
[TD="align: right"]4.5[/TD]
[/TR]
[TR]
[TD]Abimbola Dunsin (Dunsin) B[/TD]
[TD]1[/TD]
[TD]Sat 10 Aug 2019[/TD]
[TD]Phillip Mercer[/TD]
[TD="align: right"]0.25[/TD]
[TD]9.00[/TD]
[TD="align: right"]2.25[/TD]
[/TR]
[TR]
[TD]Abimbola Dunsin (Dunsin) B[/TD]
[TD]1[/TD]
[TD]Sun 11 Aug 2019[/TD]
[TD]Theresa Darling[/TD]
[TD="align: right"]0.25[/TD]
[TD]9.00[/TD]
[TD="align: right"]2.25[/TD]
[/TR]
[TR]
[TD]Afaque Solangi[/TD]
[TD]1[/TD]
[TD]Mon 12 Aug 2019[/TD]
[TD]Mohsen Taheri[/TD]
[TD="align: right"]7[/TD]
[TD]9.00[/TD]
[TD="align: right"]63[/TD]
[/TR]
[TR]
[TD]Afaque Solangi[/TD]
[TD]1[/TD]
[TD]Tue 13 Aug 2019[/TD]
[TD]Mohsen Taheri[/TD]
[TD="align: right"]7[/TD]
[TD]9.00[/TD]
[TD="align: right"]63[/TD]
[/TR]
[TR]
[TD]Afaque Solangi[/TD]
[TD]1[/TD]
[TD]Wed 14 Aug 2019[/TD]
[TD]Mohsen Taheri[/TD]
[TD="align: right"]7[/TD]
[TD]9.00[/TD]
[TD="align: right"]63[/TD]
[/TR]
[TR]
[TD]Amalia Gatou B[/TD]
[TD]1[/TD]
[TD]Thu 15 Aug 2019[/TD]
[TD]Amanda King[/TD]
[TD="align: right"]1[/TD]
[TD]9.00[/TD]
[TD="align: right"]9[/TD]
[/TR]
[TR]
[TD]Amalia Gatou B[/TD]
[TD]1[/TD]
[TD]Fri 16 Aug 2019[/TD]
[TD]Amanda King[/TD]
[TD="align: right"]0.25[/TD]
[TD]9.00[/TD]
[TD="align: right"]2.25[/TD]
[/TR]
[TR]
[TD]Amalia Gatou B[/TD]
[TD]1[/TD]
[TD]Sat 17 Aug 2019[/TD]
[TD]Amanda King[/TD]
[TD="align: right"]0.25[/TD]
[TD]9.00[/TD]
[TD="align: right"]2.25[/TD]
[/TR]
[TR]
[TD]Amalia Gatou B[/TD]
[TD]1[/TD]
[TD]Sun 18 Aug 2019[/TD]
[TD]Amanda King[/TD]
[TD="align: right"]0.5[/TD]
[TD]9.00[/TD]
[TD="align: right"]4.5[/TD]
[/TR]
</tbody>[/TABLE]
 

Excel Facts

Get help while writing formula
Click the italics "fx" icon to the left of the formula bar to open the Functions Arguments dialog. Help is displayed for each argument.
Try this code:
Code:
Dim outarr(1 To 1, 1 To 7) As Variant


lastrow = Cells(Rows.Count, "A").End(xlUp).Row
inarr = Range(Cells(1, 1), Cells(lastrow, 7))


currentname = ""
For i = 2 To lastrow '( I am assuming you have a header row otherwise this should be 1)
    If inarr(i, 1) <> currentname Then
      indi = 1
      currentname = inarr(i, 1)
      With ThisWorkbook
          .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = inarr(i, 1)
      End With
    End If
    ' copy a row
    For j = 1 To 7
      outarr(1, j) = inarr(i, j)
    Next j
    Range(Cells(indi, 1), Cells(indi, 7)) = outarr
    indi = indi + 1
Next i
End Sub
 
Upvote 0
Thank you so much for your reply - the code breaks at this point:

.Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = inarr(i, 1)

The heading (yes there is a heading row) and the first 2 sets of names have disappeared from the sheet but no tabs have been created (it would be better if all data stayed on the first sheet (if possible) and the data for each person 'copies' to a new tab (if the header could be copied to each tab that would be amazing but not essential)
 
Last edited:
Upvote 0
How about
Code:
Sub marcidee()
   Dim Cl As Range
   Dim Ws As Worksheet
   Dim Ky As Variant
   
   Set Ws = Sheets("[COLOR=#ff0000]Sheet1[/COLOR]")
   With CreateObject("scripting.dictionary")
      For Each Cl In Ws.Range("A2", Ws.Range("A" & Rows.Count).End(xlUp))
         If Cl.Value <> "" Then .item(Cl.Value) = Empty
      Next Cl
      For Each Ky In .keys
         Sheets.Add(, Sheets(Sheets.Count)).Name = Ky
         Ws.Range("A1:G1").AutoFilter 1, Ky
         Ws.AutoFilter.Range.EntireRow.Copy Sheets(Ky).Range("A1")
      Next Ky
      Ws.AutoFilterMode = False
   End With
End Sub
Change sheet name in red to suit
 
Upvote 0
this works fine for the first 3 names and then I get this error

Sheets.Add(, Sheets(Sheets.Count)).Name = Ky

I am not sure if this is something that should be included at this stage but ideally I would like column G to be totaled at the bottom of each tab

Once again thank you for your help
 
Upvote 0
Do any of your names contain more than 31 characters?
If so how do you want to name the sheet?
 
Upvote 0
Yes it looks like sometimes there is text added after the person's name - happy for you to limit that to whatever you require as I am sure the tab will be recongnisable regardless
 
Upvote 0
Ok, how about
Code:
Sub marcidee()
   Dim Cl As Range
   Dim Ws As Worksheet
   Dim Ky As Variant
   
   Set Ws = Sheets("Sheet1")
   With CreateObject("scripting.dictionary")
      For Each Cl In Ws.Range("A2", Ws.Range("A" & Rows.Count).End(xlUp))
         If Cl.Value <> "" Then .item(Cl.Value) = Empty
      Next Cl
      For Each Ky In .keys
         Sheets.Add(, Sheets(Sheets.Count)).Name = Left(Ky, 30)
         Ws.Range("A1:G1").AutoFilter 1, Ky
         Ws.AutoFilter.Range.EntireRow.Copy Sheets(Left(Ky, 30)).Range("A1")
      Next Ky
      Ws.AutoFilterMode = False
   End With
End Sub
 
Upvote 0
Brilliant - that works thank you so much for your help - is there a way we can have a total to column G on each tab?
 
Upvote 0
Add this line as shown
Code:
      For Each Ky In .keys
         Sheets.Add(, Sheets(Sheets.Count)).Name = Left(Ky, 30)
         Ws.Range("A1:G1").AutoFilter 1, Ky
         Ws.AutoFilter.Range.EntireRow.Copy Sheets(Left(Ky, 30)).Range("A1")
         [COLOR=#0000ff]Sheets(Left(Ky, 30)).Range("G" & Rows.Count).End(xlUp).Offset(1).FormulaR1C1 = "=sum(r2c:r[-1]c)"[/COLOR]
      Next Ky
 
Upvote 0

Forum statistics

Threads
1,223,227
Messages
6,170,849
Members
452,361
Latest member
d3ad3y3

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