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

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.