Correction on Sheet duplication code

Legil

New Member
Joined
Jan 9, 2023
Messages
7
Office Version
  1. 2021
Platform
  1. Windows
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

ListActivities

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

ListActivities 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


ListActivities12345Activities (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
 

Excel Facts

Can you AutoAverage in Excel?
There is a drop-down next to the AutoSum symbol. Open the drop-down to choose AVERAGE, COUNT, MAX, or MIN
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:
VBA Code:
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.
_____
 
Upvote 0
Solution
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:
VBA Code:
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

VBA Code:
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?
 
Upvote 0
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.
 
Upvote 0
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!
 
Upvote 0

Forum statistics

Threads
1,224,585
Messages
6,179,704
Members
452,938
Latest member
babeneker

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