Code to remove unwanted sheet

T

twl2009

Board Regular
Joined
Jan 7, 2016
Messages
247
Hi, at the bottom of my code there is private function sheet exists. What I would like is a sub that checks to see if the names of the existing sheets are reflected as text in the used range that is in the code above.
Basically if a name is entered in the range it creates a sheet, what I would like is for that sheet to be removed if the name is removed, so the code would need to constantly check that all sheets have a corresponding name in the used range, if not then sheet should be deleted.

Sheet1, Sheet2 and Sheet3 need to be exempt from being deleted.

I hope this makes sense.

Thanks


Code: 
<style type="text/css">p.p1 {margin: 0.0px 0.0px 0.0px 0.0px; font: 11.0px Menlo; color: #000000; background-color: #ffffff}p.p2 {margin: 0.0px 0.0px 0.0px 0.0px; font: 11.0px Menlo; background-color: #ffffff; min-height: 13.0px}p.p3 {margin: 0.0px 0.0px 0.0px 0.0px; font: 11.0px Menlo; color: #000000; background-color: #ffffff; min-height: 13.0px}p.p4 {margin: 0.0px 0.0px 0.0px 0.0px; font: 11.0px Menlo; color: #011993; background-color: #ffffff}span.s1 {color: #011993}span.s2 {color: #000000}</style>Private Sub Worksheet_Change(ByVal Target As Range)






Dim Rng1 As Range
Dim Rng2 As Range
Dim Rng3 As Range
Dim Rng4 As Range
Dim isect1 As Range
Dim isect2 As Range
Dim isect3 As Range
Dim isect4 As Range








    If Target.Count > 1 Then Exit Sub
    
    If Target.Address(False, False) = "C2" Then Call TitleCheck




    If Target.Address(False, False) = "E2" Then Call TitleCheck




    If Target.Address(False, False) = "H2" Then Call TitleCheck




    
    Set Rng1 = Range("b11:h22")
    Set Rng2 = Range("b26:h34")
    Set Rng3 = Range("b38:h46")
    Set Rng4 = Range("b50:h58")
    Set isect1 = Intersect(Target, Rng1)
    Set isect2 = Intersect(Target, Rng2)
    Set isect3 = Intersect(Target, Rng3)
    Set isect4 = Intersect(Target, Rng4)




    If isect1 Is Nothing And isect2 Is Nothing And isect3 Is Nothing And isect4 Is Nothing Then Exit Sub




    If Application.CountIf(ActiveSheet.UsedRange, Target.Value) = 1 Then
     
    If SheetExists(Target.Value) = False Then
        
    Application.ScreenUpdating = False


        Set MyActiveCell = ActiveCell
        Sheets("Timesheet").Cells.Copy
        Sheets.Add After:=Sheets(Sheets.Count)
        ActiveSheet.Paste
        Application.CutCopyMode = False
        
        ActiveSheet.Name = Target.Value
  
        ActiveSheet.Range("A2").Select
        Sheets("Labour Week").Activate
        Application.Goto MyActiveCell


    End If


    End If
    


    
    Application.ScreenUpdating = True




End Sub




Private Function SheetExists(SheetName As String) As Boolean
    On Error Resume Next
        SheetExists = (Worksheets(SheetName).Name = SheetName)
    On Error GoTo 0
[COLOR=#011993][FONT=Menlo]End[/FONT][/COLOR][FONT=Menlo] [/FONT][COLOR=#011993][FONT=Menlo]Function[/FONT][/COLOR]
 

Excel Facts

What is the shortcut key for Format Selection?
Ctrl+1 (the number one) will open the Format dialog for whatever is selected.
Sort by date Sort by votes
Not tested.

It's up to you to decide where this should be placed in your code and to define RangeOfCells

Code: 
Sub DeleteSheetIfNotInRange(ByRef RangeOfCells As Range)
    Dim WS As Worksheet
    Dim R As Range
    Dim Found As Boolean


    For Each WS In ThisWorkbook.Worksheets
            Select Case WS.Name
            Case "Sheet1", "Sheet2", "Sheet3"
            Case Else
                Found = False
                For Each R In RangeOfCells
                    Found = (R.Name = WS.Name)
                    If Found Then
                        Exit For
                    End If
                Next R
                If Not Found Then
                    Application.DisplayAlerts = False
                    WS.Delete
                    Application.DisplayAlerts = True
                End If
            End Select
    Next WS
End Sub
 
Last edited:
Upvote 0
Thanks Riv01

This is how I defined the ranges, unfortunately the sheet is not deleting when the name is deleted.

Code: 
<style type="text/css">p.p1 {margin: 0.0px 0.0px 0.0px 0.0px; font: 11.0px Menlo; background-color: #ffffff; min-height: 13.0px}p.p2 {margin: 0.0px 0.0px 0.0px 0.0px; font: 11.0px Menlo; color: #000000; background-color: #ffffff}p.p3 {margin: 0.0px 0.0px 0.0px 0.0px; font: 11.0px Menlo; color: #011993; background-color: #ffffff}span.s1 {color: #011993}span.s2 {color: #000000}</style>

    Dim WS As Worksheet
    Dim R As Range
    Dim RangeOfCells As Range
    Dim Found As Boolean


    Dim Rng5 As Range
    Dim Rng6 As Range
    Dim Rng7 As Range
    Dim Rng8 As Range


    Set Rng5 = Range("B11:H22")
    Set Rng6 = Range("B26:H34")
    Set Rng7 = Range("B38:H46")
    Set Rng8 = Range("B50:H58")
[COLOR=#000000][FONT=Menlo]    [/FONT][/COLOR][FONT=Menlo]Set[/FONT][COLOR=#000000][FONT=Menlo] RangeOfCells = Union(Rng5, Rng6, Rng7, Rng8)
[/FONT][/COLOR]
 
Upvote 0
Sorry, there was an error in one line. Try this.


Code: 
Sub DeleteSheetIfNotInRange(ByRef RangeOfCells As Range)
    Dim WS As Worksheet
    Dim R As Range
    Dim Found As Boolean

For Each WS In ThisWorkbook.Worksheets
        Select Case WS.Name
        Case "Sheet1", "Sheet2", "Sheet3"
            Debug.Print "Sheet " & WS.Name & " is exempt"
        Case Else
            Found = False
            For Each R In RangeOfCells


                Debug.Print vbCr & "Sheet Name: " & WS.Name
                Debug.Print "Cell Value: " & R.Value


                Found = (UCase(R.Value) = UCase(WS.Name))
                If Found Then
                    Exit For
                End If
            Next R
            If Not Found Then
                Application.DisplayAlerts = False
                WS.Delete
                Application.DisplayAlerts = True
            End If
        End Select
    Next WS
End Sub

If necessary, use the debug.print lines I've added to single-step the code to see what it is doing in your workbook.
 
Upvote 0
Genius, thanks Riv01

This works like a dream.

Code: 
<style type="text/css">p.p1 {margin: 0.0px 0.0px 0.0px 0.0px; font: 11.0px Menlo; background-color: #ffffff; min-height: 13.0px}p.p2 {margin: 0.0px 0.0px 0.0px 0.0px; font: 11.0px Menlo; color: #000000; background-color: #ffffff}p.p3 {margin: 0.0px 0.0px 0.0px 0.0px; font: 11.0px Menlo; color: #000000; background-color: #ffffff; min-height: 13.0px}p.p4 {margin: 0.0px 0.0px 0.0px 0.0px; font: 11.0px Menlo; color: #011993; background-color: #ffffff}span.s1 {color: #011993}span.s2 {color: #000000}</style>

Private Sub Worksheet_Change(ByVal Target As Range)




Dim Rng1 As Range
Dim Rng2 As Range
Dim Rng3 As Range
Dim Rng4 As Range
Dim isect1 As Range
Dim isect2 As Range
Dim isect3 As Range
Dim isect4 As Range




    If Target.Count > 1 Then Exit Sub
    
    If Target.Address(False, False) = "C2" Then Call TitleCheck




    If Target.Address(False, False) = "E2" Then Call TitleCheck




    If Target.Address(False, False) = "H2" Then Call TitleCheck


    
    Set Rng1 = Range("b11:h22")
    Set Rng2 = Range("b26:h34")
    Set Rng3 = Range("b38:h46")
    Set Rng4 = Range("b50:h58")
    Set isect1 = Intersect(Target, Rng1)
    Set isect2 = Intersect(Target, Rng2)
    Set isect3 = Intersect(Target, Rng3)
    Set isect4 = Intersect(Target, Rng4)




    If isect1 Is Nothing And isect2 Is Nothing And isect3 Is Nothing And isect4 Is Nothing Then Exit Sub




    If Application.CountIf(ActiveSheet.UsedRange, Target.Value) = 1 Then
     
    If SheetExists(Target.Value) = False Then
        
    Application.ScreenUpdating = False


        Set MyActiveCell = ActiveCell
        Sheets("Timesheet").Cells.Copy
        Sheets.Add After:=Sheets(Sheets.Count)
        ActiveSheet.Paste
        Application.CutCopyMode = False
        
        ActiveSheet.Name = Target.Value
  
        ActiveWindow.DisplayGridlines = False
        ActiveWindow.DisplayHeadings = False
        ActiveWindow.SplitColumn = 0
        ActiveWindow.SplitRow = 1
        ActiveWindow.FreezePanes = True
        ActiveSheet.Range("A1:AA200").Locked = True
        ActiveSheet.Range("D10:M16").Locked = False
        ActiveSheet.Range("M5:P5").Locked = False


        ActiveSheet.Range("M5").Select
        ActiveSheet.Protect


        Sheets("Labour Week").Activate
        Application.Goto MyActiveCell


    End If


    End If
        
    Application.ScreenUpdating = True








    Dim WS As Worksheet
    Dim R As Range
    Dim Found As Boolean
    Dim RangeOfCells As Range


    Set RangeOfCells = Union(Rng1, Rng2, Rng3, Rng4)


    For Each WS In ThisWorkbook.Worksheets
        Select Case WS.Name
        Case "Crew Database", "Labour Week", "Timesheet"
        Case Else
            Found = False
            For Each R In RangeOfCells
                Found = (UCase(R.Value) = UCase(WS.Name))
                If Found Then
                    Exit For
                End If
            Next R
            If Not Found Then
                Application.DisplayAlerts = False
                WS.Delete
                Application.DisplayAlerts = True
            End If
        End Select
    Next WS






End Sub








Private Function SheetExists(SheetName As String) As Boolean
 
   On Error Resume Next
        SheetExists = (Worksheets(SheetName).Name = SheetName)
    On Error GoTo 0


End Function
 
Upvote 0
You must log in or register to reply here.

Similar threads

E
  • Solved
Change value to number and percent in a sentence
Replies
3
Views
213
Joe4
Joe4
S
  • Question
VBA Code hangs on Outlook Send?
Replies
2
Views
367
shophoney
S
JeffGrant
  • Solved
VBA Code used twice, keeps table formatting on one sheet, but not on the other
Replies
4
Views
242
smozgur
smozgur
L
  • Solved
Combining Worksheet Changes
Replies
3
Views
165
Joe4
Joe4
P
  • Solved
Macro hiding all cells
Replies
3
Views
426
Peter_SSs
Peter_SSs

Forum statistics

Threads
1,215,036
Messages
6,122,794
Members
449,095
Latest member
m_smith_solihull

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top