Extracting multiple date from master sheet to new sheetsSolved/Closed

Question

Hi I run a sports tipping site and I want to extract data from my master sheet to make other sheets. I.e in sports cloumn I have multiple sports and want to send the data for each sport to a seperate sheet for each. I am not that PC Savvy so need all the help I can get as the main spreadsheet I am using is from someone else and I just need to add more to it. I came across this site and thought it looked great and I would appreciate any help you can give.. I have enclosed a picture of what my main sheet looks like .

vcoolio · Accepted Answer

Hello Alan,

Lets start by trying the following code tweaked a little to suit your needs (I think!):_

Sub CreateSheetsCopyData()

Application.DisplayAlerts = False
Application.ScreenUpdating = False

Dim MySheet As String
        Dim i As Integer
        Dim LR As Long
        Dim c As Range
        Dim ws As Worksheet
       
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

For Each cell In Range("B2:B" & LR)
    MySheet = cell.Value
    cell.EntireRow.Copy Sheets(MySheet).Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
Next cell
   
For Each ws In ActiveWorkbook.Sheets
    If ws.Range("A1") = "" Then ws.Delete
Next ws
   
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.CutCopyMode = False
MsgBox "Data transfer completed!", vbExclamation, "Status"

End Sub

The code searches Column B for the type of sport (reserve this column just for the sport type. If you need to place the league beside the sport, then insert a new column for the league alone). It then creates a new sheet for each sport and transfers the data for each sport to its individual sheet.

To implement the code:-

- At the top of your work sheet, click on the Developer tab.
- Over to the far left, click on Visual Basics.
- On the next screen that appears, click on "Insert" and then select Module.
- The grey screen turns white. In this white field, paste the above code.
- Go back to your work sheet and the Developer tab.
- Over to the far left, click on "Macros".
- A little "Macro" window will appear. In the larger field, you will see the name of the macro (in this case, CreateSheetsCopyData). Select this name and then click on "Run".

You should then see the code execute and do its thing.
We could have some niggling problems as I'm not sure as to how your data set looks, so it would be best if you could upload a sample of your work book for us to have a look at. You can upload a sample by using a free file sharing site such as DropBox, ge.tt or SpeedyShare and then posting back here with the link to your work book. Be careful with any sensitve data in your sample.

Let us know how it goes.

Cheerio,
vcoolio.

vcoolio · Answer

Hello Alan,

Have a look at the following current thread by another Poster:-

https://ccm.net/forum/affich-861487-how-to-separate-the-worksheet-based-on-data

I'm pretty sure that the code I supplied should do the job for you also, with a couple of tweaks.

Let us know what you think.

Cheerio,
vcoolio.

vcoolio · Answer

Hello Alan,

In the meantime, I've done a quick mock-up for you here:-

https://www.dropbox.com/s/h82p2d7moog8fhu/Alan180%28create%20sheets%20%26%20copy%20data%29.xlsm?dl=0

I've tweaked the code a bit further:-

Sub CreateSheetsCopyData()

Application.DisplayAlerts = False
Application.ScreenUpdating = False

Dim MySheet As String
        Dim i As Integer
        Dim LR As Long
        Dim c As Range
        Dim ws As Worksheet
       
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

For Each cell In Range("B1:B" & LR)
    MySheet = cell.Value
    cell.EntireRow.Copy Sheets(MySheet).Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
    Range("A1:I1").Copy Sheets(MySheet).Range("A1")
    Sheets(MySheet).Columns.AutoFit
Next cell
   
For Each ws In ActiveWorkbook.Sheets
    If ws.Range("A1") = "" Then ws.Delete
Next ws

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

End Sub

See what you think.

Cheerio,
vcoolio.

vcoolio · Answer

Hello Alan,

Google won't let me access the data even though I have an account and have requested your permission.

To speed things up, could you please upload your work book to DropBox and post back with the link.

Thank you.

Cheerio,
vcoolio.

vcoolio · Answer

Hello Alan,

Sorry to be a pain but although I can now access the file, Google will not let me modify it.

Google sheets don't have VBA capability (plus I don't have any experience with Google sheets) so could you please convert the file to a M/Soft .xlsx type file and then repost with a DropBox link. To do this, I believe you need to click on the File tab at the top of the Google sheet, select "Download As" and then select Microsoft.xlsx type. It should then convert to an Excel file.

Your file is very large so, if possible, just copy/convert the "Bets" sheet as this is the sheet that we need to deal with.

Thanks Alan.

Cheerio,
vcoolio.

vcoolio · Answer

Hello Alan,

The following code should do the job for you:-

Sub CreateSheetsTransferData()

Application.DisplayAlerts = False
Application.ScreenUpdating = False

Dim MySheet As String
        Dim i As Integer
        Dim LR As Long
        Dim c As Range
        Dim ws As Worksheet
       
LR = Range("A" & Rows.Count).End(xlUp).Row

For Each c In Range("C11:C" & 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
  
Sheet4.Select
  
For Each cell In Range("C11:C" & LR)
    MySheet = cell.Value
    cell.EntireRow.Copy
    Sheets(MySheet).Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
    Range("A9:W9").Copy Sheets(MySheet).Range("A1")
    Sheets(MySheet).Range("A1:W1").Columns.WrapText = False
    Sheets(MySheet).Columns.AutoFit
    
Next cell

Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.CutCopyMode = False
MsgBox "Sheets created and data transfer completed!", vbExclamation, "Status"
Sheet4.Select

End Sub


Please note though that you won't be able to implement the code into a Google spread sheet. You will need to convert the whole file to an xlsx type file, implement the code and save it as a type xlsm file.

Following is a link to your work book (converted) with the code implemented. Click on the "Cretae Sheets/Transfer" button to see it work.

https://www.dropbox.com/s/w2cd0n1qjlnvqbg/Alan180%28create%20sheets%20%26%20copy%20data%29%2C2.xlsm?dl=0

Converting your file to xlsx is the only way to make this work as formulae alone will not be able to do what is required.

Good luck!

Cheerio,
vcoolio.

vcoolio · Answer

Hello Alan,

A slight change to the code should do it.

In the code from post no. 13 above, change line 12 to:-

LR = Range("C" & Rows.Count).End(xlUp).Row

Following is the updated link to the sample file:-

https://www.dropbox.com/s/w2cd0n1qjlnvqbg/Alan180%28create%20sheets%20%26%20copy%20data%29%2C2.xlsm?dl=0

Let us know how it goes.

Cheerio,
vcoolio.

vcoolio · Answer

Hello Alan,

I'm not sure why that is because, as you can see from the sample file in my last post, the code does all that it needs to do and the sample is a copy of your actual work book. Are you receiving any error messages?

When you add more rows of data in the master sheet, you need to still click on the button to transfer the new data to its individual sheet. The code is not a Worksheet_Change event (which means that an event will happen once data is entered into a cell/row and you move onto the next cell/row to add more data).

Cheerio,
vcoolio.

vcoolio · Answer

Hello Alan,

You: #confused.com...
Me: #bewildered.com...

I suppose that you have checked my last DropBox link and seen that it all works just fine.

Anyway, in a separate module, place the following function:-

Function WorksheetExists(ByVal WorksheetName As String) As Boolean
 Dim Sht As Worksheet

For Each Sht In ActiveWorkbook.Worksheets 'ThisWorkbook.Worksheets
 If Application.Proper(Sht.Name) = Application.Proper(WorksheetName) Then
 WorksheetExists = True
 Exit Function
 End If
 Next Sht
 WorksheetExists = False
 End Function

In the code from post # 13 above, change this part of the code:-

For Each c In Range("C11:C" & 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


to

For Each c In Range("C11:C" & LR)
        Set ws = Nothing
        On Error Resume Next
        If Not WorksheetExists(c.Value) Then
        Worksheets.Add(After:=Sheets(Sheets.Count)).Name = c.Value
        End If
  Next c

and change line no. 30 to this:-

Sheets("Bets").Range("A9:W9").Copy Sheets(MySheet).Range("A1")

Let us know if this makes any difference.

Cheerio,
vcoolio.

vcoolio · Answer

Hello Alan,

Using your last sample work book, I have it working OK using the same code as in post no. 13 above but with an additional Application turn off/on as follows:-

Sub CreateSheetsTransferData()

Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Application.ScreenUpdating = False

Dim MySheet As String
        Dim i As Integer
        Dim LR As Long
        Dim c As Range
        Dim ws As Worksheet
       
LR = Range("C" & Rows.Count).End(xlUp).Row

For Each c In Range("C11:C" & 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
  
Sheets("Bets").Select
  
For Each cell In Range("C11:C" & LR)
    MySheet = cell.Value
    cell.EntireRow.Copy
    Sheets(MySheet).Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
    Sheets("Bets").Range("A9:W9").Copy Sheets(MySheet).Range("A1")
    Sheets(MySheet).Range("A1:W1").Columns.WrapText = False
    Sheets(MySheet).Columns.AutoFit
    
Next cell

Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.CutCopyMode = False
Application.Calculation = xlCalculationAutomatic
MsgBox "Sheets created and data transfer completed!", vbExclamation, "Status"
Sheets("Bets").Select

End Sub

There are a mass of formulae in the work book doing many calculations which slow and disrupt VBA execution so, by using Application.Calculation = xlCalculationManual at the begining of the code, all automatic calculations are turned off and by using Application.Calculation = xlCalculationAutomatic at the end of the code, automatic calculations are enabled again.

Hopefully.............

Cheerio,
vcoolio.

vcoolio · Answer

Hello Alan,

Following  is a link to the latest work book sample you supplied, with code implemented. You'll see that it works just fine. 

https://www.dropbox.com/s/690lvsyapgt78ou/Alan180%28create%20sheets%20%26%20copy%20data%29%2C3.xlsm?dl=0

I cannot see any reason why it won't work for you now.

Cheerio,
vcoolio.

vcoolio · Answer

Hello Alan, I've just spent quite an amount of time adding new rows of data in the "Bets" sheet (Date, Sport a couple of other columns with fake data) and its working perfectly. I repeated the process many, many times with no problems. Following is the code again adjusted to refresh each sheet so that you won't have duplication:- Sub CreateSheetsTransferData() Application.Calculation = xlCalculationManual Application.DisplayAlerts = False Application.ScreenUpdating = False Dim MySheet As String Dim i As Integer Dim LR As Long Dim c As Range Dim ws As Worksheet Dim ar As Variant LR = Range("C" & Rows.Count).End(xlUp).Row For Each Sht In Worksheets If Sht.Name <> "Bets" And Sht.Name <> "Settings" And Sht.Name <> "Deposits" And Sht.Name <> "Intro" And Sht.Name <> "Available Funds" _ And Sht.Name <> "Performance Summary" And Sht.Name <> "Tipper Analysis" And Sht.Name <> "Closing Odds Analysis" And Sht.Name <> "Closing Line Analysis" And Sht.Name <> "Performance Graph" Then Sht.UsedRange.Offset(1).ClearContents End If Next Sht For Each c In Range("C11:C" & 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 Sheets("Bets").Select For Each cell In Range("C11:C" & LR) MySheet = cell.Value cell.EntireRow.Copy Sheets(MySheet).Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues Sheets("Bets").Range("A9:W9").Copy Sheets(MySheet).Range("A1") Sheets(MySheet).Range("A1:W1").Columns.WrapText = False Sheets(MySheet).Columns.AutoFit Sheets(MySheet).Columns(1).NumberFormat = "dd/mm/yyyy" Next cell Application.DisplayAlerts = True Application.ScreenUpdating = True Application.CutCopyMode = False Application.Calculation = xlCalculationAutomatic MsgBox "Sheets created and data transfer completed!", vbExclamation, "Status" Sheets("Bets").Select End Sub Here is the work book with the adjusted code:- https://www.dropbox.com/s/690lvsyapgt78ou/Alan180%28create%20sheets%20%26%20copy%20data%29%2C3.xlsm?dl=0 Cheerio, vcoolio.

alan180 · Answer

Hi RayH

I apologize for not crediting you with your help, I didn't realize you was also involved. May I now take this opportunity to thank you for your input and your your help in sorting my issue out. Hope you and the family have a great Xmas and a Happy New Year.

Extracting multiple date from master sheet to new sheets

13 responses

Subscribe To Our Newsletter!