CODEWITHSUNDEEP
excelvba
hiro
hiro

Reputation: 1

Vba: Delete excel sheets not mentioned in the list (the list only contains numeric value)

I need to delete sheets not mentioned in the given list(Range is A7:A350). I found this vba but the problem is it deletes all the sheets from my workbook, maybe because sheetname is in numeric. I would really appreciate any help.

Sub Deletenotinlist()
Dim i As Long
Dim cnt As Long
Dim xWb, actWs As Worksheet
Set actWs = ThisWorkbook.ActiveSheet
cnt = 0
Application.DisplayAlerts = False
For i = Sheets.Count To 1 Step -1
    If Not ThisWorkbook.Sheets(i) Is actWs Then
        xWb = Application.Match(Sheets(i).Name, actWs.Range("A7:A350"), 0)
        If IsError(xWb) Then
            ThisWorkbook.Sheets(i).Delete
            cnt = cnt + 1
        End If
    End If
Next
Application.DisplayAlerts = True
If cnt = 0 Then
    MsgBox "Not find the sheets to be seleted", vbInformation, "Kutools for Excel"
Else
    MsgBox "Have deleted" & cnt & "worksheets"
End If

End Sub

Upvotes: 0

Views: 819

Answers (2)

FaneDuru
FaneDuru

Reputation: 42236

What you try doing can be accomplished in many ways, but I tried adapting your code to place the missing sheets name in an array and select them at the end. If selection is convenient, you can replace Select with Delete:

Sub Deletenotinlist()
 Dim i As Long, cnt As Long, xWb, actWs As Worksheet, lastR As Long, arrSh(), k As Long

 Set actWs = ThisWorkbook.ActiveSheet
 lastR = actWs.Range("A" & actWs.rows.count).End(xlUp).row
 ReDim arrSh(ThisWorkbook.Sheets.count - 1)
 cnt = 0
 For i = 1 To Sheets.count
    If Not ThisWorkbook.Sheets(i) Is actWs Then
        xWb = Application.match(Sheets(i).Name, actWs.Range("A7:A" & lastR), 0)
        If IsError(xWb) Then
            arrSh(k) = CStr(ThisWorkbook.Sheets(i).Name): k = k + 1
            cnt = cnt + 1
        End If
    End If
 Next
 ReDim Preserve arrSh(k - 1) 'keep only the filled array elements
 Sheets(arrSh).Select 'You can replace 'Select' with 'Delete', if it returns correctly

 If cnt = 0 Then
    MsgBox "Not find the sheets to be seleted", vbInformation, "Kutools for Excel"
 Else
    MsgBox "Have deleted " & cnt & " worksheets"
 End If
End Sub

It processes all existing values in column A:A, starting from the 7th row.

But I'm afraid that the range you try processing does not contain any existing sheet name...

In order to test the above supposition, please run the next test sub, which will place all existing sheets name in column B:B, starting from the 7th row. Then delete some rows and run the previous code, replacing "A" with "B" in lastR = actWs.Range("A" &... and actWs.Range("A7:A" & lastR). The code should select all missing sheets:

Sub testArraySheets()
  Dim arrSh, ws As Worksheet, k As Long
  
  ReDim arrSh(ActiveWorkbook.Sheets.count - 1)
  For Each ws In ActiveWorkbook.Sheets
       If Not ws Is ActiveSheet Then
            arrSh(k) = ws.Name: k = k + 1
       End If
  Next
  ActiveSheet.Range("B7").Resize(UBound(arrSh) + 1, 1).Value = Application.Transpose(arrSh)
End Sub

Upvotes: 0

Rajput
Rajput

Reputation: 605

I think I would do it this way.

Sub DeleteSheets()

Dim sht As Worksheet
Dim rng As Range

Set rng = Sheets("Sheet1").Range("A2:A10")
Application.DisplayAlerts = False

For Each sht In ActiveWorkbook.Worksheets
    If Application.CountIf(rng, sht.Name) = 0 Then
        sht.Delete
    End If

Next sht

Application.DisplayAlerts = True
End Sub

Upvotes: 0

Related Questions