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

Closed
Vlookup Posts 1 Registration date Thursday February 18, 2016 Status Member Last seen February 18, 2016 - Feb 18, 2016 at 03:09 PM
vcoolio Posts 1411 Registration date Thursday July 24, 2014 Status Moderator Last seen September 6, 2024 - Feb 19, 2016 at 07:41 AM
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.

1 response

vcoolio Posts 1411 Registration date Thursday July 24, 2014 Status Moderator Last seen September 6, 2024 262
Feb 19, 2016 at 07:41 AM
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.
0