Do while loop to delete worksheets if worksheets are not in the specified list

**kchm_2000** · 04-26-2011, 07:04 AM

Hi,

I have a list of worksheets on sheet1, i want to perform a do while loop to delete the sheets that are not equals to the sheets in the list so far i have this formula. Can someone help me see where I went wrong

Sub Delete()

Dim ws As Worksheet
Dim x As Integer

x = 2

Do While Worksheets("Sheet1").Cells(x, 2) <> ""
    
    For Each ws In ActiveWorkbook
        If ws.Name <> Worksheets("Sheet1").Cells(x, 2) Then
        ws.Delete
        
        End If
    Next ws
    
    x = x + 1
    
Loop


End Sub

**highbarger** · 04-26-2011, 07:23 AM

Sub deletesheets()
Dim ws As Worksheet
For Each ws In Worksheets
If WorksheetFunction.CountIf(Worksheets(1).Range("B1:B100"), ws.Name) < 1 Then ws.Delete
Next ws
End Sub

**kchm_2000** · 04-26-2011, 07:33 AM

can there be a solution that works if the worksheet names on column B are like made up of alphabets.

**jaslake** · 04-26-2011, 03:02 PM

Hi kchm_2000
Try this code

Option Explicit
Sub Find_ws()
    Dim ws As Worksheet
    Dim Findws As String
    Dim Rng As Range
    Dim LR As Long
    Application.ScreenUpdating = False
    LR = Range("B" & Rows.Count).End(xlUp).Row
    For Each ws In ActiveWorkbook.Worksheets
        Findws = ws.Name
        If Trim(Findws) <> "" Then
            With Sheets("Sheet1").Range("B2:B" & LR)
                Set Rng = .Find(What:=Findws, _
                        After:=.Cells(.Cells.Count), _
                        LookIn:=xlValues, _
                        LookAt:=xlWhole, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlNext, _
                        MatchCase:=False)
                If Not Rng Is Nothing Then
                    '                do nothing
                Else
                    If ws.Name <> ActiveSheet.Name Then
                        Application.DisplayAlerts = False
                        ws.Delete
                        Application.DisplayAlerts = True
                    End If
                End If
            End With
        End If
    Next ws
    Application.ScreenUpdating = True
End Sub

Let me know of issues.