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

[tezza]

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

 

[tezza]

I've run through the process using the recorder so here it is in it's crudest form:

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]

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.

 

[tezza]

Ok, I'll give it a go:

https://atalianworld-my.sharepoint....xFvr-I6E7QKhIBfL3rXi2nZYMpGtR_8Yu0jw?e=1rGPff

Sheet1 Holds the data

Sheet2 is a template for each site to use

Sheet3 is a filled in example of the first sites data in sheet1

The idea is pretty basic, each site needs a list of names that belong to them which I'm trying to auto populate.

Regards

 

[Fluff]

How about

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]

Thank you so much, works like a dream and you've done the tab names as well.

You're a star

 

[Fluff]

You're welcome & thanks for the feedback

 

[mumps]

A slight modification to Fluff's code to delete all the sheets except the first two:

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

 

[tezza]

That's a nice finishing touch, thank you.

 

[mumps]

You're very welcome.