Grab data, create new sheet, rename tab, paste data

tezza

Active Member
Joined
Sep 10, 2006
Messages
375
Office Version
  1. 2016
  2. 2010
Platform
  1. Windows
  2. Web
Hi All

I'm trying to speed up a process and in need to your help.

I requested something similar a while back in an earlier post but can't adapt it.

Here's what I do right now for each new tab.

Sheet1 (Called Data) holds duplicate site names in Col A and staff names in Col B (sometimes duplicate)

Sheet2 (Called Tracker) is setup as a template to hold the data from Data sheet.

What I need:

Remove duplicate name from Col B

Copy Tracker sheet and put at the end.

Copy the first site name from Col A and put into the new Tracker sheet at D5

Check to see how many staff their are at that site and list them all in the new Tracker sheet from A11 downwards (paste value only).

Rename the tab to the site name that was put in D5

Repeat the process until there is a new tab for each site with a list of staff that work there.

I will need to start this process from fresh each month so could use something that will remove all tabs expect the original two.

Hope you can help.

Terry
 
Last edited:

Excel Facts

Who is Mr Spreadsheet?
Author John Walkenbach was Mr Spreadsheet until his retirement in June 2019.
I've run through the process using the recorder so here it is in it's crudest form:

Code:
Sub Aberdare()
'
' dryrun Macro
'

'
    Sheets("Tracker").Select                            'Select Tracker sheet
    Sheets("Tracker").Copy Before:=Sheets(3)            'Copy before sheet 3
    Range("D5:K5").Select                               'Select range in new sheet
    With Selection                                      'Select group of Cells
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False                              'Don't know if this is needed
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .mergecells = True
    End With
    Selection.UnMerge                                   'Unmerge them
    Sheets("Sheet1").Select                             'Select Sheet1
    ActiveSheet.Range("$A$1:$C$245").AutoFilter Field:=3, Criteria1:= _
        "Aberdare, 2015"                                'Filer dropdown list to first item
    Range("D2:D19").Select                              'Select Range
    Selection.Copy                                      'Copy it
    Sheets("Tracker (2)").Select                        'Select the New Sheet
    Range("A11").Select                                 'Select Cell A11
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False                       'Paste Values
    Sheets("Sheet1").Select                             'Select Sheet1
    Range("C2").Select                                  'Select Cell C2
    Application.CutCopyMode = False
    Selection.Copy                                      'Copy it
    Sheets("Tracker (2)").Select                        'Back to New sheet
    Range("D5").Select                                  'Select Cell D5
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False                       'Paste Valus
    Range("D5:K5").Select                               'Select D5:K5
    Application.CutCopyMode = False
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False                              'Still 'Don't know if this is needed
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .mergecells = False
    End With
    Selection.Merge                                     'Remerge the cells
    Sheets("Sheet1").Select                             'Select Sheet1
    ActiveSheet.Range("$A$1:$C$245").AutoFilter Field:=3 'Clear dropdown filter
End Sub

In a nutshell it's filtering out data from a drop down list that I have to manually select and copying it to specific cells in a newly duplicated sheet.

It I only had to do it once this would be good enough but I have to do it many times, which I don't know how to setup so need help with that to go through the full drop down list automatically and place the data from the new list into a newly copied sheet.

I've setup a little routine that renames the tabs to what's in D5, although it has issues if the name already exists.

Please feel free to also streamline the code.

Thank you
 
Upvote 0
Can you post a screen shot of what your data looks like? Section B at this link has instructions on how to post a screen shot: https://www.mrexcel.com/forum/board-announcements/127080-guidelines-forum-use.html Alternately, you could upload a copy of your file to a free site such as www.box.com. or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. Include a detailed explanation of what you would like to do referring to specific cells, rows, columns and worksheets. If the workbook contains confidential information, you could replace it with generic data.
 
Upvote 0
How about
Code:
Sub tezza()
   Dim Cl As Range
   Dim Dic As Object
   Dim Ky As Variant
   Dim Dws As Worksheet, Tws As Worksheet
   
   Set Dws = Sheets("Sheet1")
   Set Tws = Sheets("Tracker")
   Set Dic = CreateObject("scripting.dictionary")
   For Each Cl In Dws.Range("C2", Dws.Range("A" & Rows.Count).End(xlUp).Offset(, 2))
      If Not Dic.Exists(Cl.Value) Then Dic.Add Cl.Value, CreateObject("scripting.dictionary")
      Dic(Cl.Value)(Cl.Offset(, -1).Value) = Empty
   Next Cl
   For Each Ky In Dic.Keys
      Tws.Copy , Sheets(Sheets.Count)
      ActiveSheet.Name = Left(Ky, 31)
      Range("D5").Value = Ky
      Range("A11").Resize(Dic(Ky).Count).Value = Application.Transpose(Dic(Ky).Keys)
   Next Ky
End Sub
One of your store names is more than 31 characters, so I have just taken the first 31 characters for the sheet name
 
Upvote 0
Solution
Thank you so much, works like a dream and you've done the tab names as well.

You're a star :)
 
Upvote 0
You're welcome & thanks for the feedback
 
Upvote 0
A slight modification to Fluff's code to delete all the sheets except the first two:
Code:
Sub tezza()
   Dim Cl As Range, Dic As Object, Ky As Variant, Dws As Worksheet, Tws As Worksheet, ws As Worksheet
   Set Dws = Sheets("Sheet1")
   Set Tws = Sheets("Tracker")
   Application.DisplayAlerts = False
    For Each ws In Sheets
        If ws.Name <> "Sheet1" And ws.Name <> "Tracker" Then
            ws.Delete
        End If
    Next ws
    Application.DisplayAlerts = True
   Set Dic = CreateObject("scripting.dictionary")
   For Each Cl In Dws.Range("C2", Dws.Range("A" & Rows.Count).End(xlUp).Offset(, 2))
      If Not Dic.Exists(Cl.Value) Then Dic.Add Cl.Value, CreateObject("scripting.dictionary")
      Dic(Cl.Value)(Cl.Offset(, -1).Value) = Empty
   Next Cl
   For Each Ky In Dic.Keys
      Tws.Copy , Sheets(Sheets.Count)
      ActiveSheet.Name = Left(Ky, 31)
      Range("D5").Value = Ky
      Range("A11").Resize(Dic(Ky).Count).Value = Application.Transpose(Dic(Ky).Keys)
   Next Ky
End Sub
 
Upvote 0
That's a nice finishing touch, thank you.
 
Upvote 0

Forum statistics

Threads
1,213,489
Messages
6,113,949
Members
448,534
Latest member
benefuexx

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