Correction on Sheet duplication code

[Legil]

Hi Everyone, I need help just with a quick look into the code I've been working on the recent days

I am working on a file to map activity times for some team mates and so far, we have two initial tabs, the tab "List" and the tab "Activities", like this

List	Activities

So far, lets say that the information in the "List" tab is the information per each teammate with an ID (1,2,3,4,5) and what I wanted is to copy the "activities" tab for each teammate, and then change the name of this new duplicate, like this

List

Activities

1 (First Duplicate of "Activities")

2 (Second Duplicate of "Activities")

3 (Third Duplicate of "Activities")

4 (Fourth Duplicate of "Activities")

5 (Fifth Duplicate of "Activities")

Now, I have a functional code, but I am getting the next result, it works for Any number of registrys

List

Activities

1

2

3

4

5

Activities (2)

Is there a way we can clean up the code so that I don't get the "Activities (2)" Tab at the end? this is the code I'm using


Sub MakeSheets()

Dim newname As String
Dim current_sheet As Worksheet

Set current_sheet = Sheets("Activities")

lastcell = ThisWorkbook.Worksheets("List").Cells(Rows.Count, 1).End(xlUp).Row 'The ID column on "List" tab is A and it starts in the second roW'

For i = 2 To lastcell

With ThisWorkbook

newname = ThisWorkbook.Worksheets("Información por colaborador").Cells(i, 1).Value

current_sheet.Copy After:=Sheets(Sheets.Count)

ActiveSheet.Name = newname

End With

Next

ThisWorkbook.Worksheets("Información por colaborador").Activate
ThisWorkbook.Worksheets("Información por colaborador").Cells(1, 1).Select


End Sub

 

[DanteAmor]

So far, lets say that the information in the "List" tab is the information per each teammate with an ID (1,2,3,4,5) and what I wanted is to copy the "activities" tab for each teammate, and then change the name of this new duplicate, like this

On this line you should have the name of the sheet "list":
newname = ThisWorkbook.Worksheets("Información por colaborador").Cells(i, 1).Value
Should be:
newname = ThisWorkbook.Worksheets("List").Cells(i, 1).Value
Try this:

Sub MakeSheets()
  Dim newname As String
  Dim current_sheet As Worksheet
  Dim i As Long, lastcell As Long
  
  With ThisWorkbook
    Set current_sheet = Sheets("Activities")
    lastcell = .Worksheets("List").Cells(Rows.Count, 1).End(xlUp).Row 'The ID column on "List" tab is A and it starts in the second roW'
    
    For i = 2 To lastcell
      newname = .Worksheets("List").Cells(i, 1).Value
      current_sheet.Copy After:=.Sheets(.Sheets.Count)
      .ActiveSheet.Name = newname
    Next
    
    .Worksheets("Información por colaborador").Activate
    .Worksheets("Información por colaborador").Cells(1, 1).Select
  End With
End Sub

Note Code Tag:
In future please use code tags when posting code.
How to Post Your VBA Code it makes your code easier to read and copy and it also maintains VBA formatting.
_____

 

[Legil]

On this line you should have the name of the sheet "list":
newname = ThisWorkbook.Worksheets("Información por colaborador").Cells(i, 1).Value
Should be:
newname = ThisWorkbook.Worksheets("List").Cells(i, 1).Value
Try this:

Sub MakeSheets()
  Dim newname As String
  Dim current_sheet As Worksheet
  Dim i As Long, lastcell As Long
 
  With ThisWorkbook
    Set current_sheet = Sheets("Activities")
    lastcell = .Worksheets("List").Cells(Rows.Count, 1).End(xlUp).Row 'The ID column on "List" tab is A and it starts in the second roW'
   
    For i = 2 To lastcell
      newname = .Worksheets("List").Cells(i, 1).Value
      current_sheet.Copy After:=.Sheets(.Sheets.Count)
      .ActiveSheet.Name = newname
    Next
   
    .Worksheets("Información por colaborador").Activate
    .Worksheets("Información por colaborador").Cells(1, 1).Select
  End With
End Sub

Note Code Tag:
In future please use code tags when posting code.
How to Post Your VBA Code it makes your code easier to read and copy and it also maintains VBA formatting.
_____

Yep, sorry about the typo, so far my code looks like this

Sub MakeSheet()

    Dim newname As String
    Dim current_sheet As Worksheet

Set current_sheet = Sheets("Activities")

lastcell = ThisWorkbook.Worksheets("List").Cells(Rows.Count, 1).End(xlUp).Row

For i = 1 To lastcell

With ThisWorkbook

newname = ThisWorkbook.Worksheets("List").Cells(i, 1).Value

current_sheet.Copy After:=Sheets(Sheets.Count)

.ActiveSheet.Name = newname

End With

Next

ThisWorkbook.Worksheets("List").Activate
ThisWorkbook.Worksheets("List").Cells(1, 1).Select


End Sub

But I'm still getting the same result

List​

Activities​

1​

2​

3​

4​

5​

Activities (1)​

any suggestions?

 

[DanteAmor]

In my test it does not generate an additional sheet.
Check the data you have in cells A2 to A6, also check if you have more data after cell A6, that is, you may have cells with blank spaces or maybe some formula.

 

[Legil]

In my test it does not generate an additional sheet.
Check the data you have in cells A2 to A6, also check if you have more data after cell A6, that is, you may have cells with blank spaces or maybe some formula.

Thanks to your message i figured out what happened. Turns out the columns with the information was set up as a table, so there were 'empty' rows that excel was considering as 'blank' rows, so it was a matter of converting it back to range and that was it

Thanks a lot for the support!