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

tezza

Board Regular
Joined
Sep 10, 2006
Messages
165
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:

Some videos you may like

Excel Facts

Wildcard in VLOOKUP
Use =VLOOKUP("Apple*" to find apple, Apple, or applesauce

tezza

Board Regular
Joined
Sep 10, 2006
Messages
165
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
 

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
9,189
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.
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
42,721
Office Version
365
Platform
Windows
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
 

tezza

Board Regular
Joined
Sep 10, 2006
Messages
165
Thank you so much, works like a dream and you've done the tab names as well.

You're a star :)
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
42,721
Office Version
365
Platform
Windows
You're welcome & thanks for the feedback
 

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
9,189
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
 

Watch MrExcel Video

Forum statistics

Threads
1,102,445
Messages
5,486,933
Members
407,572
Latest member
smcexcel

This Week's Hot Topics

Top