Delete all tabs except one

[m5edward]

Hi Everyone,

Just looking for some code to help me delete tabs after a workbook split.

Basically, I have a macro that splits a worksheets (not workbooks) by a unique identifier found in column A. I would like all tabs except the relevant one to be deleted from the new file, and there are too many tabs to name them in the code. Any ideas?

Here is the code I have so far.

Sub SplitWB()
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False
Application.ScreenUpdating = False


ActiveWorkbook.Save


Dim OutputFolderName As String
 OutputFolderName = ""
    Set myDlg = Application.FileDialog(msoFileDialogFolderPicker)
    myDlg.AllowMultiSelect = False
    myDlg.Title = "Select Output Folder for Touchstone Files:"
    If myDlg.Show = -1 Then OutputFolderName = myDlg.SelectedItems(1) & "\" Else Exit Sub
    Set myDlg = Nothing
      
    Application.CutCopyMode = False
    
    '''''''''''''''''''''''''''''
    '''''''''''''''''''''''''''''
           
    Dim d As Object, c As Range, k, tmp As String, unique(500)
    i = 0
    
    With ActiveSheet
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    End With


    Set d = CreateObject("scripting.dictionary")
    For Each c In Range(Cells(1, 1), Cells(lastRow, 1))
        tmp = Trim(c.Value)
        If Len(tmp) > 0 Then d(tmp) = d(tmp) + 1
    Next c


    For Each k In d.keys
        Debug.Print k, d(k)
         i = i + 1
         unique(i) = k
    Next k
    
    UniqueCount = i
           
'start deleting
    
For i = 1 To UniqueCount
    
    'Actions for new workbook
    wpath = Application.ActiveWorkbook.FullName
    wbook = ActiveWorkbook.Name
    wsheet = ActiveSheet.Name
    
    ActiveWorkbook.SaveAs Filename:=OutputFolderName & unique(i), FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False


    For j = 1 To lastRow
        If Range("A" & j) <> "" And Range("A" & j) <> unique(i) Then
            Rows(j).Delete
            j = j - 1
        End If
    Next
    
    'hide helper columns
    
    If HideC = False And DeleteC = True Then
       ' Columns("A:D").Hidden = True
    End If




       
    Range("E8").Select
    
    
    'Select Instructions tab
    'Worksheets("Guidelines").Activate
                  
    'Save new workbook
    ActiveWorkbook.Close SaveChanges:=True
    Workbooks.Open (wpath)
    
    'ActiveWorkbook.Close False
      
    Workbooks(wbook).Activate
    
Next




Application.DisplayAlerts = True
Application.ScreenUpdating = True




MsgBox ("Macro has completed successfully!" & vbNewLine & vbNewLine & "Generated files can be found in the following directory:" & vbNewLine & OutputFolderName)
    
Application.AskToUpdateLinks = True
End Sub

And here is background on the project.

The project: It deals with very sensitive HR/performance data, and I need to send 1000s of employees' data to their individual managers (about 100 managers who can only see their team's data, and no one else's), so I need about 100 files split (1 each for each manager).

The file:
- Many different tabs, separated by role.
- First column is a unique identifier made by concatenating the Manager's name with the job title ex. John Stevens_Office Manager

The task:
- John Stevens will have team members in many different job roles, and needs all that data in one file, separated into tabs by job role.

Sample Data

Tab 1: Office Manager
[TABLE="class: cms_table, width: 500"]
<tbody>[TR]
[TD]Identifier[/TD]
[TD]Last Name[/TD]
[TD]First Name[/TD]
[TD]Performance[/TD]
[/TR]
[TR]
[TD]John Stevens_Office Manager[/TD]
[TD]Killjoy[/TD]
[TD]Heidi[/TD]
[TD]8/10[/TD]
[/TR]
[TR]
[TD]Lindsay Brown_Office Manager[/TD]
[TD]Wilcox[/TD]
[TD]Tommy[/TD]
[TD]9/10[/TD]
[/TR]
[TR]
[TD]Tom Fields_Office Manager[/TD]
[TD]Thorne[/TD]
[TD]Ronald[/TD]
[TD]7/10[/TD]
[/TR]
</tbody>[/TABLE]


Tab 2: Office Coordinator
[TABLE="class: cms_table, width: 500"]
<tbody>[TR]
[TD]Identifier[/TD]
[TD]Last Name[/TD]
[TD]First Name[/TD]
[TD]Performance[/TD]
[/TR]
[TR]
[TD]John Stevens_Office Coordinator[/TD]
[TD]Shields[/TD]
[TD]Betty[/TD]
[TD]7/10[/TD]
[/TR]
[TR]
[TD]Lindsay Brown_Office Coordinator[/TD]
[TD]Johnson[/TD]
[TD]Craig[/TD]
[TD]9/10[/TD]
[/TR]
[TR]
[TD]Tom Fields_Office Coordinator[/TD]
[TD]Corgan[/TD]
[TD]Billy[/TD]
[TD]10/10[/TD]
[/TR]
</tbody>[/TABLE]


Tab 3: AR Associate
[TABLE="class: cms_table, width: 500"]
<tbody>[TR]
[TD]Identifier[/TD]
[TD]Last Name[/TD]
[TD]First Name[/TD]
[TD]Performance[/TD]
[/TR]
[TR]
[TD]John Stevens_AR Associate[/TD]
[TD]Spears[/TD]
[TD]Britney[/TD]
[TD]4/10[/TD]
[/TR]
[TR]
[TD]Lindsay Brown_AR Associate[/TD]
[TD]Cobain[/TD]
[TD]Kurt[/TD]
[TD]10/10[/TD]
[/TR]
[TR]
[TD]Tom Fields_AR Associate[/TD]
[TD]Wilson[/TD]
[TD]Brian[/TD]
[TD]9/10[/TD]
[/TR]
</tbody>[/TABLE]



Based on that sample data, the ideal macro would give me 3 files with 3 worksheets in each, and 1 row of data in each worksheet. Ideally, the file name would just be the manager's name and the worksheets' names would be the job titles.



Thanks,


Mark

 

[Jonmo1]

This will delete all tabs except the one named "Not This One"

Sub DeleteTabs()
Dim ws As Worksheet, MySheet As String

'Define Which Sheet to Keep
MySheet = "Not This One"

'Set that sheet as visible, there must be at least 1 visible sheet in a book
Sheets(MySheet).Visible = True

'Suppress prompt to confirm deleting sheets.
Application.DisplayAlerts = False

'Delete all other sheets
For Each ws In Sheets
    If ws.Name <> MySheet Then ws.Delete
Next ws
End Sub