How to delete worksheets except those on a list? - excel

Question

I have a workbook with 13 sheets. I'm trying to delete some of those worksheets.
I defined a list with the name of all sheets I want to keep. I am trying to make a condition so sheets with a name different from those in the list are deleted.
Sub PREPARE_FILE()
Dim ws As Variant
ws = Array("Sheet1", "Sheet2", "Sheet3") 'Reminder that the Workbook has 13 sheets total.
For Each ws In Sheets(ws)
If ws <> [SOMETHING] Then
Delete = True
Next
Application.DisplayAlerts = True
What could I replace [SOMETHING] with, or how could it be designed differently?

Answer 1

Edit: Didn't read properly, and only now I see you trying to keep those sheets. If so, then try:
Sub PREPARE_FILE()
Dim ws As Worksheet
Dim arr As Variant: arr = Array("Sheet1", "Sheet2", "Sheet3")
Application.DisplayAlerts = False
For Each ws In ThisWorkbook.Worksheets
If Not (IsNumeric(Application.Match(ws.Name, arr, 0))) Then ws.Delete
Next ws
Application.DisplayAlerts = True
End Sub

Answer 2

Assuming we want to retain Sheet1, Sheet2, Sheet3; give this a try:
Option Explicit
Sub SheetKiller()
Dim i As Long, nm As String, tot As Long
Application.DisplayAlerts = False
tot = Sheets.Count
For i = tot To 1 Step -1
nm = Sheets(i).Name
If nm = "Sheet1" Or nm = "Sheet2" Or nm = "Sheet3" Then
'Do nothing
Else
If Sheets.Count <> 1 Then
Sheets(i).Delete
End If
End If
Next i
End Sub
Note:
The If Sheets.Count <> 1 Then is there to prevent all sheets being deleted if there are no sheets meeting the "save" criteria.

Answer 3

Delete Sheets With Exceptions
The first procedure, deleteSheetsUsage, illustrates how to use the second (main) procedure, deleteSheets.
The third procedure, TESTdeleteSheetsExpected, tests the expected behavior of the second procedure. To run the test, add a new workbook containing sheets Sheet1, Sheet2 and Sheet3. Copy at least the second and third procedure into an added standard module, e.g. Module1.
The fourth procedure, Result, just shows the expected result of the third procedure in the Immediate window.
The Code
Option Explicit
Sub deleteSheetsUsage()
Const SheetNames As String = "Sheet1,Sheet2,Sheet3"
Dim wb As Workbook
Set wb = ThisWorkbook
Dim Keepers() As String
Keepers = Split(SheetNames, ",")
deleteSheets wb, Keepers
End Sub
Sub deleteSheets( _
aWorkbook As Workbook, _
SheetsToKeep() As String)
Const ProcName As String = "deleteSheets"
On Error GoTo clearError
If Not aWorkbook Is Nothing Then
On Error Resume Next
Evaluate LBound(SheetsToKeep)
If Err = False Then ' 'If Not Err Then' doesn't work!
On Error GoTo clearError
If UBound(SheetsToKeep) >= LBound(SheetsToKeep) Then
With CreateObject("Scripting.Dictionary")
Dim sh As Object
For Each sh In aWorkbook.Sheets
If IsError(Application.Match(sh.Name, _
SheetsToKeep, 0)) Then
.Item(sh.Name) = Empty
Else
' Sheet name found in SheetsToKeep.
' No action taken.
End If
Next sh
Select Case .Count
Case 0
Debug.Print "'" & ProcName & "': " _
& "No sheets to delete. " _
& "No action taken."
Case Is < aWorkbook.Sheets.Count
Application.DisplayAlerts = False
aWorkbook.Sheets(.Keys).Delete
Application.DisplayAlerts = True
If .Count > 1 Then
Debug.Print "'" & ProcName & "': " _
& "Deleted " & .Count & " sheets."
Else
Debug.Print "'" & ProcName & "': " _
& "Deleted 1 sheet."
End If
Case Else ' Case Is >= aWorkbook.Sheets.Count
Debug.Print "'" & ProcName & "': " _
& "Attempted to delete too many sheets. " _
& "No action taken."
End Select
End With
Else
' ('UBound(SheetsToKeep) gt LBound(SheetsToKeep)').
Debug.Print "'" & ProcName & "': " _
& "'Sheets To Keep Array' is empty. " _
& "No action taken."
End If
Else
On Error GoTo clearError
Debug.Print "'" & ProcName & "': " _
& "'Sheets To Keep Array' is only declared. " _
& "No action taken."
End If
Else
Debug.Print "'" & ProcName & "': " _
& "Workbook not defined ('Nothing'). " _
& "No action taken."
End If
ProcExit:
Exit Sub
clearError:
Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
Resume ProcExit
End Sub
Sub TESTdeleteSheetsExpected()
' Test "Workbook not defined ('Nothing')."
Dim wb As Workbook
Dim Keepers() As String
deleteSheets wb, Keepers
' Test "'Sheets To Keep Array' is only declared."
Set wb = ThisWorkbook
deleteSheets wb, Keepers
' Test "'Sheets To Keep Array' is empty."
Dim SheetNames As String
SheetNames = ""
Keepers = Split(SheetNames, ",")
deleteSheets wb, Keepers
' Test multiple sheets OK.
wb.Worksheets.Add Count:=2
SheetNames = "Sheet1,Sheet2,Sheet3"
Keepers = Split(SheetNames, ",")
deleteSheets wb, Keepers
' Test one sheet OK.
wb.Worksheets.Add
SheetNames = "Sheet1,Sheet2,Sheet3"
Keepers = Split(SheetNames, ",")
deleteSheets wb, Keepers
' Test 'No sheets to delete.'
SheetNames = "Sheet1,Sheet2,Sheet3"
Keepers = Split(SheetNames, ",")
deleteSheets wb, Keepers
' Test 'Attempting to delete too many sheets.'
SheetNames = "Sheet100"
Keepers = Split(SheetNames, ",")
deleteSheets wb, Keepers
End Sub
Sub Result()
'deleteSheets': Workbook not defined ('Nothing'). No action taken.
'deleteSheets': 'Sheets To Keep Array' is only declared. No action taken.
'deleteSheets': 'Sheets To Keep Array' is empty. No action taken.
'deleteSheets': Deleted 2 sheets.
'deleteSheets': Deleted 1 sheet.
'deleteSheets': No sheets to delete. No action taken.
'deleteSheets': Attempted to delete too many sheets. No action taken.
End Sub