VBA Loop to remove specific named worksheets within a folder

R

RyanHawkeye

New Member
Joined
Apr 9, 2015
Messages
29
Hello, I'm needing some help from you experts out there. I have a folder with multiple xlsx spreadsheets within it. I would truly love to have VBA Loop code rummage through all the folder's xlsx spreadsheets and keep worksheets named AR20, AR21, VT77, and GG65 and delete all the other worksheets. Any help will be appreciated. Thanks
 
Sort by date Sort by votes
Fuji said:
try
Code: 
Sub test()
    Dim myDir$, fn$, e, myList, ws As Worksheet, flg As Boolean
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then myDir = .SelectedItems(1) & "\"
    End With
    If myDir = "" Then Exit Sub
    myList = Array("AR20", "AR21", "VT77", "GG65")
    fn = Dir(myDir & "*.xls*")
    Do While fn <> ""
        If myDir & fn <> ThisWorkbook.FullName Then
            With Workbooks.Open(myDir & fn)
                For Each e In myList
                    flg = Evaluate("isref('" & e & "'!a1)")
                    If flg Then Exit For
                Next
                If flg Then
                    For Each ws In .Worksheets
                        If IsNumeric(Application.Match(ws.Name, myList, 0)) Then
                            ws.Visible = -1
                        Else
                            Application.DisplayAlerts = False
                            ws.Delete
                            Application.DisplayAlerts = True
                        End If
                    Next
                End If
                .Close True
            End With
        End If
        fn = Dir
    Loop
End Sub
Click to expand...
Hello Fuji ~ I appreciate your help with this too. Im not sure where I put my directory at within your code? I run it and it looks like it just has me manually go to the desired folder and click ok. I ran into the same problem as the user Logit's code. It opens up each spreadsheet and asks if I want to Cancel or Save. When you have 100s of records this is time consuming so I had to abort this. I also noticed that this code didnt delete the worksheets that did not have the needed spreadsheets. Also upon saving these updated spreadsheets is it possible to save them with a sensitivity level of "Confidential"? Thanks, I appreciate your help with this very much! :)
 
Upvote 0

Excel Facts

Which lookup functions find a value equal or greater than the lookup value?
MATCH uses -1 to find larger value (lookup table must be sorted ZA). XLOOKUP uses 1 to find values greater and does not need to be sorted.
See if the following removed the "Save or Cancel" messages :

VBA Code: 
Sub KeepSpecificSheets()
    Dim FolderPath As String
    Dim Filename As String
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim MasterWorkbook As Workbook
    Dim KeepSheets As Object
    Dim wsName As String
    Dim FoundSheet As Boolean
    
    ' Set the folder path
    FolderPath = "C:\Your\Folder\Path\" ' Change this to your folder path
    If Right(FolderPath, 1) <> "\" Then FolderPath = FolderPath & "\"
    
    ' Store the master workbook
    Set MasterWorkbook = ThisWorkbook
    
    ' Define sheets to keep in a dictionary
    Set KeepSheets = CreateObject("Scripting.Dictionary")
    KeepSheets.Add "AR20", True
    KeepSheets.Add "AR21", True
    KeepSheets.Add "VT77", True
    KeepSheets.Add "GG65", True
    
    ' Loop through all xlsx files in the folder
    Filename = Dir(FolderPath & "*.xlsx")
    Do While Filename <> ""
        ' Open the workbook if it is not the master workbook
        If StrComp(FolderPath & Filename, MasterWorkbook.FullName, vbTextCompare) <> 0 Then
            Set wb = Workbooks.Open(FolderPath & Filename)
            FoundSheet = False ' Initialize flag
            
            ' Check if any sheets to keep exist
            For Each ws In wb.Worksheets
                If KeepSheets.exists(ws.Name) Then
                    FoundSheet = True
                    Exit For
                End If
            Next ws
            
            ' If no sheets match the keep list, delete the workbook
            If Not FoundSheet Then
                Application.DisplayAlerts = False
                wb.Close SaveChanges:=False ' Close without saving changes
                Kill FolderPath & Filename ' Delete the file
                Application.DisplayAlerts = True
            Else
                ' Loop through all worksheets in the workbook to delete non-matching sheets
                
                For Each ws In wb.Worksheets
                    wsName = ws.Name
                    If Not KeepSheets.exists(wsName) Then
                    Application.DisplayAlerts = False
                        ws.Visible = xlSheetVisible ' Make sheet visible if hidden
                        ws.Delete
                    Application.DisplayAlerts = True
                    End If
                Next ws
                
                Application.DisplayAlerts = False
                ' Save and close the workbook
                wb.Close SaveChanges:=True
                Application.DisplayAlerts = True
            End If
        End If
        
        ' Get the next file
        Filename = Dir
    Loop
    
    MsgBox "Process Completed!", vbInformation
End Sub

Also, this portion of the macro should delete the folder (as requested) if none of the sheets exists :

Code: 
' If no sheets match the keep list, delete the workbook

            If Not FoundSheet Then

                Application.DisplayAlerts = False

                wb.Close SaveChanges:=False ' Close without saving changes

                Kill FolderPath & Filename ' Delete the file

                Application.DisplayAlerts = True

            Else
 
Upvote 0
Logit said:
See if the following removed the "Save or Cancel" messages :

VBA Code: 
Sub KeepSpecificSheets()
    Dim FolderPath As String
    Dim Filename As String
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim MasterWorkbook As Workbook
    Dim KeepSheets As Object
    Dim wsName As String
    Dim FoundSheet As Boolean
   
    ' Set the folder path
    FolderPath = "C:\Your\Folder\Path\" ' Change this to your folder path
    If Right(FolderPath, 1) <> "\" Then FolderPath = FolderPath & "\"
   
    ' Store the master workbook
    Set MasterWorkbook = ThisWorkbook
   
    ' Define sheets to keep in a dictionary
    Set KeepSheets = CreateObject("Scripting.Dictionary")
    KeepSheets.Add "AR20", True
    KeepSheets.Add "AR21", True
    KeepSheets.Add "VT77", True
    KeepSheets.Add "GG65", True
   
    ' Loop through all xlsx files in the folder
    Filename = Dir(FolderPath & "*.xlsx")
    Do While Filename <> ""
        ' Open the workbook if it is not the master workbook
        If StrComp(FolderPath & Filename, MasterWorkbook.FullName, vbTextCompare) <> 0 Then
            Set wb = Workbooks.Open(FolderPath & Filename)
            FoundSheet = False ' Initialize flag
           
            ' Check if any sheets to keep exist
            For Each ws In wb.Worksheets
                If KeepSheets.exists(ws.Name) Then
                    FoundSheet = True
                    Exit For
                End If
            Next ws
           
            ' If no sheets match the keep list, delete the workbook
            If Not FoundSheet Then
                Application.DisplayAlerts = False
                wb.Close SaveChanges:=False ' Close without saving changes
                Kill FolderPath & Filename ' Delete the file
                Application.DisplayAlerts = True
            Else
                ' Loop through all worksheets in the workbook to delete non-matching sheets
               
                For Each ws In wb.Worksheets
                    wsName = ws.Name
                    If Not KeepSheets.exists(wsName) Then
                    Application.DisplayAlerts = False
                        ws.Visible = xlSheetVisible ' Make sheet visible if hidden
                        ws.Delete
                    Application.DisplayAlerts = True
                    End If
                Next ws
               
                Application.DisplayAlerts = False
                ' Save and close the workbook
                wb.Close SaveChanges:=True
                Application.DisplayAlerts = True
            End If
        End If
       
        ' Get the next file
        Filename = Dir
    Loop
   
    MsgBox "Process Completed!", vbInformation
End Sub

Also, this portion of the macro should delete the folder (as requested) if none of the sheets exists :

Code: 
' If no sheets match the keep list, delete the workbook

            If Not FoundSheet Then

                Application.DisplayAlerts = False

                wb.Close SaveChanges:=False ' Close without saving changes

                Kill FolderPath & Filename ' Delete the file

                Application.DisplayAlerts = True

            Else
Click to expand...
It is still opening each up individually and asking to Save or Cancel. It might be doing this because our company has it set that we need to assign a Sensitivity Level to each spreadsheet. Are you able to assign a Sensitivity level of "Confidential" within this code prior to Saving it? Thanks so much. :)
1734991915491.png
 
Upvote 0
I added two lines of code at the beginning and end of the macro. Try this :

VBA Code: 
Option Explicit

Sub KeepSpecificSheets()
    Dim FolderPath As String
    Dim Filename As String
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim MasterWorkbook As Workbook
    Dim KeepSheets As Object
    Dim wsName As String
    Dim FoundSheet As Boolean
    
    Application.DisplayAlerts = False
    
    ' Set the folder path
    FolderPath = "C:\Your\Folder\Path\" ' Change this to your folder path
    If Right(FolderPath, 1) <> "\" Then FolderPath = FolderPath & "\"
    
    ' Store the master workbook
    Set MasterWorkbook = ThisWorkbook
    
    ' Define sheets to keep in a dictionary
    Set KeepSheets = CreateObject("Scripting.Dictionary")
    KeepSheets.Add "AR20", True
    KeepSheets.Add "AR21", True
    KeepSheets.Add "VT77", True
    KeepSheets.Add "GG65", True
    
    ' Loop through all xlsx files in the folder
    Filename = Dir(FolderPath & "*.xlsx")
    Do While Filename <> ""
        ' Open the workbook if it is not the master workbook
        If StrComp(FolderPath & Filename, MasterWorkbook.FullName, vbTextCompare) <> 0 Then
            Set wb = Workbooks.Open(FolderPath & Filename)
            FoundSheet = False ' Initialize flag
            
            ' Check if any sheets to keep exist
            For Each ws In wb.Worksheets
                If KeepSheets.exists(ws.Name) Then
                    FoundSheet = True
                    Exit For
                End If
            Next ws
            
            ' If no sheets match the keep list, delete the workbook
            If Not FoundSheet Then
                Application.DisplayAlerts = False
                wb.Close SaveChanges:=False ' Close without saving changes
                Kill FolderPath & Filename ' Delete the file
                Application.DisplayAlerts = True
            Else
                ' Loop through all worksheets in the workbook to delete non-matching sheets
                
                For Each ws In wb.Worksheets
                    wsName = ws.Name
                    If Not KeepSheets.exists(wsName) Then
                    Application.DisplayAlerts = False
                        ws.Visible = xlSheetVisible ' Make sheet visible if hidden
                        ws.Delete
                    Application.DisplayAlerts = True
                    End If
                Next ws
                
                Application.DisplayAlerts = False
                ' Save and close the workbook
                wb.Close SaveChanges:=True
                Application.DisplayAlerts = True
            End If
        End If
        
        ' Get the next file
        Filename = Dir
    Loop
    
    Application.DisplayAlerts = True
    
    MsgBox "Process Completed!", vbInformation
End Sub
 
Upvote 0
Not sure if this solves the issue...
Rich (BB code): 
Sub test()
    Dim myDir$, fn$, e, myList, ws As Worksheet, flg As Boolean
    myDir = "YourFolderPathHere\"  '<--- must have path separator, \, at the end.
    myList = Array("AR20", "AR21", "VT77", "GG65")
    fn = Dir(myDir & "*.xls*")
    Do While fn <> ""
        If myDir & fn <> ThisWorkbook.FullName Then
            With Workbooks.Open(myDir & fn)
                For Each e In myList
                    flg = Evaluate("isref('" & e & "'!a1)")
                    If flg Then Exit For
                Next
                If flg Then
                    For Each ws In .Worksheets
                        If IsNumeric(Application.Match(ws.Name, myList, 0)) Then
                            ws.Visible = -1
                        Else
                            Application.DisplayAlerts = False
                            ws.Delete
                            Application.DisplayAlerts = True
                        End If
                    Next
                End If
                Application.DisplayAlerts = False
                .Close True
                Application.DisplayAlerts = True
            End With
        End If
        fn = Dir
    Loop
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

G
  • Question Question
remove columns from multiple Excel-files in a folder
Replies
5
Views
338
gjvv
G
R
  • Question Question
Add a code or number at the end of the file name using VBA (Looped)
Replies
3
Views
124
HighAndWilder
H
H
  • Question Question
Macro to List Folders excluding Data Stamp within E:\Cobian
Replies
0
Views
73
howard
H
D
  • Solved
VB search folder for older version of a file and move it to archive
Replies
7
Views
246
Davefromleeds
D
A
  • Question Question
How arrange files names based on modified date within folders and subfolders
Replies
4
Views
114
Alaa mg
A

Forum statistics

Threads
1,224,858
Messages
6,181,431
Members
453,040
Latest member
Santero

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