Forum Discussion
VBA Delete all sheets excluding a few known
- Jan 10, 2024
Lorenzo The snippet you found can be applied as follows:
Sub DeleteOtherSheets() Dim tbl As ListObject, arr() As Variant, i As Long Set tbl = ThisWorkbook.Worksheets("HIDDEN_DEV_SHEET").ListObjects(1) ReDim arr(1 To tbl.ListRows.Count) For i = 1 To tbl.ListRows.Count arr(i) = tbl.DataBodyRange(i, 1).Value Next i Dim Item As Worksheet Application.ScreenUpdating = False Application.DisplayAlerts = False On Error Resume Next For Each Item In ThisWorkbook.Worksheets If UBound(Filter(arr, Item.Name)) = -1 Then Item.Delete Next Item Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub
I was working on something similar with arrays, using the Filter function to reduce the list of sheet names upon each iteration by setting the optional Include parameter to False...
Sub DeleteOtherSheets() 'Load all worksheet names into an array Dim sheetList() As Variant, wsCount As Long, i As Long wsCount = ThisWorkbook.Worksheets.Count ReDim sheetList(1 To wsCount) For i = 1 To wsCount sheetList(i) = ThisWorkbook.Worksheets(i).Name Next i 'Remove HIDDEN_DEV_SHEET from the sheet list Dim ws As Worksheet, removeList As Variant Set ws = ThisWorkbook.Worksheets("HIDDEN_DEV_SHEET") removeList = Filter(sheetList, ws.Name, False) 'Remove each name in the table from the sheet list Dim tbl As ListObject, rowCount As Long Set tbl = ws.ListObjects(1) rowCount = tbl.ListRows.Count If rowCount > 0 Then Dim arr As Variant arr = tbl.ListColumns(1).DataBodyRange.Value If rowCount = 1 Then ' single item If Len(arr) > 0 Then removeList = Filter(removeList, arr, False) End If Else ' multiple items For i = LBound(arr, 1) To UBound(arr, 1) If Len(arr(i, 1)) > 0 Then removeList = Filter(removeList, arr(i, 1), False) End If Next i End If End If 'Delete each worksheet in the filtered list On Error Resume Next Application.ScreenUpdating = False Application.DisplayAlerts = False For i = LBound(removeList) To UBound(removeList) ThisWorkbook.Worksheets(removeList(i)).Delete Next i Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub
EDIT: I discovered a few little quirks with this method (ie: if the table contains blank rows), so the code has been updated to handle those scenarios.
FYI: I believe the 'Type Mismatch" error is caused when using a 2-dimensional array in the SourceArray parameter. An array created directly from a range (ie: arr = rg.Value) is automatically 2-dimensional, even if it's a single column. Cheers!
Lorenzo Further to my previous reply, if there's a chance the worksheet names may be changed for any reason, you may want to set custom "Code Names" for each worksheet you want to keep, then delete by Item.CodeName: For example:
Worksheet Properties: CodeName
Sub DeleteOtherSheets()
Dim Item As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
For Each Item In ThisWorkbook.Worksheets
Select Case Item.CodeName
Case "Keep1", "Keep2", "Keep3", "Keep4"
'Do nothing
Case Else
Item.Delete
End Select
Next Item
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Very interesting ideas and they're highly appreciated. Unfortunately the list of known sheets might evolve/change and - where possible - I'd like to have nothing to change on the VB side
The actual scenario is much more complex than what I exposed...
THANK YOU