Macro to Create, Name and Fill New Sheets Based Data SetClosed

Question

Sorry, I realize this question gets asked all the time. What I'm looking for seems different enough that I will need some specific help. The post right before mine asks a similar question but the answers will be pretty different. Thanks in advance for the help!

I am trying to create a macro that will create, name and fill-in new sheets in my workbook automatically based on data in an initial worksheet. What I have is a workbook with 1 sheet with columns titled "Player, Team, Points" and I want the macro to create new sheets for each unique team and add the appropriate players and 

For example the starting dataset would be:
Player Team Points
John Bulls 5
Katie Jets 7

And I'd like to create new worksheets that would use the team name as the sheet name and then, in the new sheet, paste the player name, team, and points in the correct row. I don't care about the header since that will not take long to copy/paste in the other sheets. I have 416 total rows so it would take a long time to go through on my own and I thought this would be a good time to start shaping up my macro/VB skills.

I found a post that is roughly similar here: https://ccm.net/forum/affich-720350-excel-a-macro-to-create-new-workbook-and-copy-data

But the data and formatting are so different that I'm lost on how to overhaul it for what I'm doing. I can make lots of adjustments for my data but the goals we have or too different for me to just copy/paste and modify his solution.

Thanks so much.

vcoolio · Answer

Hello Vlookup,

I'm guessing a little here as to what you would like to do, however, I have two possible options for you:-

Code 1:-


Sub CreateSheetsCopyData()

Application.ScreenUpdating = False

Dim I As Integer
        Dim LR As Long
        Dim c As Range
        Dim ws As Worksheet
        Dim TSearch As String

LR = Range("A" & Rows.Count).End(xlUp).Row

For Each c In Range("B2:B" & LR)
        Set ws = Nothing
        On Error Resume Next
        Set ws = Worksheets(c.Value)
        If ws Is Nothing Then
        Worksheets.Add(After:=Sheets(Sheets.Count)).Name = c.Value
        End If
  Next c
  
Sheet1.Select

TSearch = InputBox("Please select the required team name.")
If TSearch = vbNullString Then Exit Sub

Sheets(TSearch).UsedRange.ClearContents
         Range("B1", Range("B" & Rows.Count).End(xlUp)).AutoFilter 1, TSearch
         Range("A1", Range("C" & Rows.Count).End(xlUp)).Copy Sheets(TSearch).Range("A" & Rows.Count).End(xlUp)
    
   [B1].AutoFilter
 
Application.ScreenUpdating = True
Application.CutCopyMode = False
MsgBox "Data transfer completed!", vbExclamation, "Status"
Sheets(TSearch).Select

End Sub



Code 2:-

Sub CreateSheetsCopyData2()

Application.ScreenUpdating = False

Dim I As Integer
        Dim LR As Long
        Dim c As Range
        Dim ws As Worksheet
        Dim ar As Variant
        
LR = Range("A" & Rows.Count).End(xlUp).Row
ar = Array("Bulls", "Sharks", "Tigers", "Wallabies", "Roosters", "Saints")

For Each c In Range("B2:B" & LR)
        Set ws = Nothing
        On Error Resume Next
        Set ws = Worksheets(c.Value)
        If ws Is Nothing Then
        Worksheets.Add(After:=Sheets(Sheets.Count)).Name = c.Value
        End If
  Next c
 
Sheet1.Select

For I = 0 To UBound(ar)
         Sheets(ar(i)).UsedRange.ClearContents
         Range("B1", Range("B" & Rows.Count).End(xlUp)).AutoFilter 1, ar(i)
         Range("A1", Range("C" & Rows.Count).End(xlUp)).Copy Sheets(ar(i)).Range("A" & Rows.Count).End(xlUp)
     Next
     
[B1].AutoFilter

Application.ScreenUpdating = True
Application.CutCopyMode = False
MsgBox "Data transfer completed!", vbExclamation, "Status"

End Sub

Following is a link to my test work book for you to peruse:-

https://www.dropbox.com/s/w5urf5bee7qoqbx/Vlookup%28create%20sheets%2C%20transfer%20data%29.xlsm?dl=0

Click on either button to see the options at work.

The first code above creates sheets in the name of each team then uses an Input Box in which you enter a team name then click OK to transfer each row of data for that team to its individual sheet. The individual sheets refresh so that there won't be any duplicate details as I assume that you want to keep all data on your main sheet (Sheet 1 in the code). You can add and delete in the main sheet and any amended details will still be transferred to the individual sheets. With the Input Box, you have control of which team and details are transferred.

With the second code above, much the same happens except that all details of every team are transferred at once. No Input Box is used. As you can see in the code, the team names are kept in an array. You can add or delete names from the array as required. If you add/delete a team from the team list in your main sheet, ensure that you also add/delete it in the array.

In both codes, headings are transferred also.

I hope that this helps.

Cheerio,
vcoolio.

Macro to Create, Name and Fill New Sheets Based Data Set

1 response

Similar discussions

Subscribe To Our Newsletter!