Forum Discussion

Lorenzo's avatar
Lorenzo
Silver Contributor
Jan 10, 2024
Solved

VBA Delete all sheets excluding a few known

Hi guys   I thought I could solve this on my own but I'm not sure I'd be able to do it in the end 😞   Basically, what I need to do is: #1 Store all existing sheetnames from the active workbook ...
  • djclements's avatar
    djclements
    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!

Resources