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!
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' 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
ElseIt 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.
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 SubSub 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 SubI haven't forgotten about this. I will try this once I am back in the office after Christmas break. Thank you
Fuji, I haven't forgotten about this. I will try this once I am back in the office after Christmas break. Thank you
Hello Logit, I hope you had a wonderful Holiday. Im just getting back in the swing of things. I did try this code and it is still popping up each spreadsheet individually and wanting me to select a Sensitivity(which needs to be "Confidential") and then Save the Spreadsheet manually before moving on to the next spreadsheet. So I would say the next step is if your ingenuity could figure out how to have it save automatically while giving it a "Confidential" Sensitivity. Thanks for your help with this Logit, I truly do appreciate it.
Hello Fuji, I hope you had a happy holidays. Im just getting back in the swing of things myself. I did try your code and it is still popping up each spreadsheet individually and wanting me to select a Sensitivity(which needs to be "Confidential") and then Save the Spreadsheet manually before moving on to the next spreadsheet. Also I notice that spreadsheets that dont have any of the tabs I need are still showing up, those spreadsheets without the needed tab(s) can be totally deleted. I would say the next step is if you can get it to save automatically while giving it a "Confidential" Sensitivity and removing any spreadsheet that doesn't have a single tab I need. I appreciate your help with this Fuji, Thanks again!
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
wb.Close SaveChanges:=False ' Close without saving changes
Kill FolderPath & Filename ' Delete the file
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
ws.Visible = xlSheetVisible ' Make sheet visible if hidden
ws.Delete
End If
Next ws
' Save the workbook with a 'Confidential' setting
Dim SavePath As String
SavePath = FolderPath & wb.Name & "_Confidential.xlsx"
' Add a custom document property to indicate confidentiality
On Error Resume Next
wb.CustomDocumentProperties.Add Name:="Confidential", _
LinkToContent:=False, Type:=msoPropertyTypeString, Value:="True"
On Error GoTo 0
' Save the workbook
wb.SaveAs Filename:=SavePath, FileFormat:=xlOpenXMLWorkbook
wb.Close SaveChanges:=False
End If
End If
' Get the next file
Filename = Dir
Loop
Application.DisplayAlerts = True
MsgBox "Process Completed!", vbInformation
End Sub
