New tab when name changes in column A

[marcidee]

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

Abimbola Dunsin (Dunsin) B	1	Thu 08 Aug 2019	Peter Howes	0.75	9.00	6.75
Abimbola Dunsin (Dunsin) B	1	Fri 09 Aug 2019	Peter Howes	0.5	9.00	4.5
Abimbola Dunsin (Dunsin) B	1	Sat 10 Aug 2019	Phillip Mercer	0.25	9.00	2.25
Abimbola Dunsin (Dunsin) B	1	Sun 11 Aug 2019	Theresa Darling	0.25	9.00	2.25
Afaque Solangi	1	Mon 12 Aug 2019	Mohsen Taheri	7	9.00	63
Afaque Solangi	1	Tue 13 Aug 2019	Mohsen Taheri	7	9.00	63
Afaque Solangi	1	Wed 14 Aug 2019	Mohsen Taheri	7	9.00	63
Amalia Gatou B	1	Thu 15 Aug 2019	Amanda King	1	9.00	9
Amalia Gatou B	1	Fri 16 Aug 2019	Amanda King	0.25	9.00	2.25
Amalia Gatou B	1	Sat 17 Aug 2019	Amanda King	0.25	9.00	2.25
Amalia Gatou B	1	Sun 18 Aug 2019	Amanda King	0.5	9.00	4.5

<tbody>
</tbody>

 

[offthelip]

Try this 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

 

[marcidee]

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)

 

[Fluff]

How about

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

 

[marcidee]

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

 

[Fluff]

Do any of your names contain more than 31 characters?
If so how do you want to name the sheet?

 

[marcidee]

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

 

[Fluff]

Ok, how about

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

 

[marcidee]

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?

 

[Fluff]

Add this line as shown

      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