Macro: Dynamic creation of sheet based on cell value then copy range to the new sheet

I've created a workbook which tracks stats for my local pool league. There are team, partner sets and player stats collected per week. I also want to track player stats on a per game basis and this is the reason for the post. I've run into a problem in that I can't copy the range of collected data for each player per game played to just one sheet for all players due to the number of rows that would be generated for the maximum players that could be involved in the league (144), the maximum number of weeks (48) and maximum number of games per player per season (240). This combined with the number of INDEX array formulas that would collect this data per player on another sheet makes the collection for each individual player run very slow for each entry. I've determined that I need to separate data on separate sheets per the week being collected. This would be a total of 48 sheets. This way, rows per sheet to be indexed will be less than 800 for each week instead of 35,000 for all weeks combined.

What I want to do, and need help doing is as follows:

The sheet named "Scorecard" is where I enter all of the stats to be collected for each match. On the Scorecard sheet there is a drop down for the week number of the current match being entered, 1 through 48. A range of data, for instance AK112:AU171, is collected from the information entered for each player within the current match on the scorecard. I want to push a button and have the macro look at the week number (Q3), check if there is already a worksheet named as "FullPlayerStatsW1" and if it doesn't exist, create it. "FullPlayerStatsW" would be the name of each sheet followed by the week numbers from 1 through 48. After creating the sheet, the macro should copy the range AK112:AU171 and paste it starting in column A row 1 of the newly created worksheet and paste all other games from other matches for that week at the first blank row found in the new sheet, A:K. All data should be pasted as values only on the FullPlayerStatsW (1-48) sheets.

Let me know if I need to clarify anything. Thanks!!

I’m not a VBA guru and wouldn’t know where to begin with this. I can record a macro with the best of them but this will take writing code in VBA, which I have no experience doing.

Logically, if this helps at all, the steps would be something like this written in human terms. I'm sorry if I'm being repetitive.

1. A week number is chosen, 1 through 48, from the Scorecard sheet Q3 drop down menu.

2. All data is entered on the Scorecard sheet for each player and each game they played.

3. A button is pressed containing a macro that reads the data in Q3 and combines it with “FullPlayerStatsW” with the week number at the end to result with “FullPlayerStatsW1” for week 1 and “FullPlayerStatsW2” for week 2, etc. The macro then searches the workbook to see if the sheet name “FullPlayerStatsW1” exists yet and if it doesn’t then the sheet is created and named “FullPlayerStatsW1”.

4. The macro continues once it has verified that the sheet exists or after the sheet is created by then copying a range of cells from the Scorecard sheet, AK112:AU171, and then pastes the range into the new sheet in columns A:K on the first row found to have nothing in it.

Maybe if I break this down into smaller chunks....

I found some code for adding a sheet based on a cell reference.

Sub Add_Worksheet_Name_From_Cell()
Dim NumberSheets As Integer
NumberSheets = ActiveWorkbook.Worksheets.Count
Sheets.Add After:=Sheets(NumberSheets)
ActiveSheet.Name = Sheet1.[Q3].Value
Sheet1.Activate
End Sub

This works well and creates a sheet with whatever data that exists in ScoreCard!Q3 as the new sheet name. But, if the macro runs again after that new sheet is already created I get a runtime error 1004 (cannot rename a sheet to the same name as another sheet) and a new sheet is created as "Sheet4" or the next incremental number.

I found other code for error checking that is supposed to check if the name already exists. I tried to combine the two and came up with the following:

Sub FindCreateSheet()
Dim NumberSheets As Integer
Dim wSheet As Worksheet
On Error Resume Next
Set wSheet = Worksheets("Sheet1")
If wSheet Is Nothing Then
Else
NumberSheets = ActiveWorkbook.Worksheets.Count
Sheets.Add after:=Sheets(NumberSheets)
ActiveSheet.Name = Sheet1.[Q3].Value
Sheet1.Activate
End If
On Error GoTo 0
End Sub

This runs without errors but doesn't create the sheet and essentially does nothing.

Also, I would like the newly created sheets to combine both the cell contents and "FullPlayerStatsW" so the sheet names are that and a number at the end such as "FullPlayerStatsW1", "FullPlayerStatsW2", etc.

Hi dm@stams. Thank you so much for the reply! I do appreciate the information.

However, me being so inept with VBA I am unable to discern what I would need to do to manipulate Jerry's code for my needs. I don't need to make a copy of an existing sheet. I need to create a new sheet and name it starting with "FullPlayerStatsW" and then add the value of the cell ScoreCard!Q3 (result being "FullPlayerStatsW1" or FullPlayerStatsW and any number from 1 through 48 depending on the week selected added to the end) onto the end of it after the code searches the workbook and determines that "FullPlayerStatsW1" exists or not. If the sheet already exists it will just move on to the range copy, still to be worked out.

I've been working on this project for about 200 hours in all over the course of about a year. This is (so-far) the first thing I've not been able to figure out on my own with the help of information I've found in sites like this one.

I'm unsure what you mean when you are referring to 'coping ranges' as your post isn't very clear. But from what I gather, you'd like to copy certain ranges from your scorecard sheet 1 at a time, with each range of data being placed on the next available row???? If so, try the following (just change the ranges as needed)

Sub Add_Worksheet_Name_From_Cell()
Dim snewsheet As String
For Each wkSheet In ThisWorkbook.Worksheets
    If wkSheet.name = "FullPlayerStatsW" & Sheet1.[Q3].Value Then
       exists = True
       MsgBox " Sorry This sheet already exists"
       End If
    Next
If exists = False Then
Dim NumberSheets As Integer
NumberSheets = ActiveWorkbook.Worksheets.Count
Sheets.Add After:=Sheets(NumberSheets)
ActiveSheet.name = "FullPlayerStatsW" & Sheet1.[Q3].Value
snewsheet = ActiveSheet.name
Sheet1.Range("AK112:AU171").Copy
Sheets(snewsheet).Range("A65536").End(xlUp).Offset(0, 0).PasteSpecial xlPasteValues
Sheet1.Range("AK172:AU230").Copy
Sheets(snewsheet).Range("A65536").End(xlUp).Offset(0, 0).PasteSpecial xlPasteValues
Sheet1.Activate
End If
End Sub

If you need to add further ranges copy these two lines

Sheet1.Range("AK172:AU230").Copy
Sheets(snewsheet).Range("A65536").End(xlUp).Offset(0, 0).PasteSpecial xlPasteValues

here

snewsheet = ActiveSheet.name
Sheet1.Range("AK112:AU171").Copy
Sheets(snewsheet).Range("A65536").End(xlUp).Offset(0, 0).PasteSpecial xlPasteValues
Sheet1.Range("AK172:AU230").Copy
Sheets(snewsheet).Range("A65536").End(xlUp).Offset(0, 0).PasteSpecial xlPasteValues
<<<<<<<<<Here>>>>>>>>>>>>>>>>
Sheet1.Activate

I haven't tested this code so hopefully it will work. If not, hopefully it will point you in the right direction.

Hi dm@stams,

I'm sorry I wasn't very clear. I'll try to be better in the future. Thank you for your help.

As it turns out, you were able to extrapolate what I needed almost exactly. You are light years ahead of me with VBA! Your first code (Sub Add_Worksheet_Name_From_Cell()) worked beautifully and does exactly what I want it to do except that when I enter the stats onto the scorecard for the next match of the same week and then run the macro it sees that the new sheet is already created and stops with the message. There will always be multiple matches being played between pool teams each week so the code needs to be able to see that the new sheet has already been created and then just copy the specific range of cells from the ScoreCard sheet (again for the new match of the same week) and put them at the end of those that have already been copied from previously entered matches for that week onto the new sheet. Also, I hadn't thought of this originally but, can the newly created sheet be created and also hidden?

The exact same range will be copied from the ScoreCard sheet to the new or matching week sheet.I removed the second range from your code and pasted below.

Sub Add_Worksheet_Name_From_Cell()
Dim snewsheet As String
For Each wkSheet In ThisWorkbook.Worksheets
    If wkSheet.Name = "FullPlayerStatsW" & Sheet1.[Q3].Value Then
       exists = True
       MsgBox " Sorry This sheet already exists"
       End If
    Next
If exists = False Then
Dim NumberSheets As Integer
NumberSheets = ActiveWorkbook.Worksheets.Count
Sheets.Add After:=Sheets(NumberSheets)
ActiveSheet.Name = "FullPlayerStatsW" & Sheet1.[Q3].Value
snewsheet = ActiveSheet.Name
Sheet1.Range("AK112:AU171").Copy
Sheets(snewsheet).Range("A65536").End(xlUp).Offset(0, 0).PasteSpecial xlPasteValues
Sheet1.Activate
End If
End Sub

Again, thanks very much for your assistance, DM.

Bump to be seen again.

Help?

Sub Add_Worksheet_Name_From_Cell()
Dim snewsheet As String
For Each wkSheet In ThisWorkbook.Worksheets
    If wkSheet.Name = "FullPlayerStatsW" & Sheet1.[Q3].Value Then
       exists = True
       End If
    Next
If exists = False Then
Dim NumberSheets As Integer
NumberSheets = ActiveWorkbook.Worksheets.Count
Sheets.Add After:=Sheets(NumberSheets)
ActiveSheet.Name = "FullPlayerStatsW" & Sheet1.[Q3].Value
snewsheet = ActiveSheet.Name
Sheet1.Range("AK112:AU171").Copy
Sheets(snewsheet).Range("A65536").End(xlUp).Offset(0, 0).PasteSpecial xlPasteValues
Sheet1.Activate
End If
End Sub

I'm going to buy a book today to try to learn VBA. Please advise if you have a suggestion for a good one.

However, in the meantime I really could use some help still with this specific problem. The above code that dm@stams provided for me needs to still copy the range of cells to the sheet that is looked for (and then created if it doesn't exist yet) if the sheet does already exist instead of just determining that the sheet exists and stopping with the message box to tell me the same. I've tried numerous ways to do this myself and I'm getting nowhere.

I think that the code to copy the range to the sheet if it does exist would be inserted after "exists = True":

    If wkSheet.Name = "FullPlayerStatsW" & Sheet1.[Q3].Value Then
       exists = True
       MsgBox " Sorry This sheet already exists"
       End If

But would be in place of the MsgBox. So if the combination of "FullPlayerStatsW" & Sheet1.[Q3] already exists as a sheet name, then it would just copy the range of AK112:AU171 to the sheet at the first row found to be empty.

I'm trying. Please throw me a bone.

Thanks!

As per forum best practices, the finished and working version of the VBA function I've been seeking help with on this forum is listed below. Thank you dm@stamds for the initial help. I purchased a book "Excel 2010 Power Programming with VBA" by John Walkenbach and after enough reading I was finally able to make the necessary changes to make this thing do exactly what I wanted it to do, and as it turned out there wasn't much that needed to be changed from dm's original code.

Sub Add_Worksheet_Name_From_Cell()

Dim snewsheet As String
Dim wkSheet As Excel.Worksheet
Dim exists As Boolean

Application.ScreenUpdating = False

For Each wkSheet In ThisWorkbook.Worksheets
    If wkSheet.Name = "FullPlayerStatsW" & Sheet1.[Q3].Value Then
       exists = True
       MsgBox " Sorry This sheet already exists"
       snewsheet = wkSheet.Name 
       Exit For 
    End If
Next wkSheet

If exists = False Then
    Dim NumberSheets As Integer
    NumberSheets = ActiveWorkbook.Worksheets.Count
    Sheets.Add After:=Sheets(NumberSheets)
    ActiveSheet.Name = "FullPlayerStatsW" & Sheet1.[Q3].Value
    snewsheet = ActiveSheet.Name
    Sheet1.Range("AK112:AU171").Copy
    Sheets(snewsheet).Range("A65536").End(xlUp).Offset(0, 0).PasteSpecial xlPasteValues
    Sheet1.Activate
Else    
    Sheet1.Range("AK112:AU171").Copy
     Sheets(snewsheet).Range("A65536").End(xlUp).Offset(0, 0).PasteSpecial xlPasteValues
    Sheet1.Activate
End If

Dim wks As Worksheet

    For Each wks In ActiveWorkbook.Worksheets
           If LCase(wks.Name) Like LCase("FullPlayerStatsW*") Then wks.Visible = False
    Next wks

End Sub