I wish I could but I cant, hence why I am adding the Sensitivity label...sorry. Do you think my other suggestion could work? I meant you got it to work perfectly before with the exception that the previously named spreadsheets still existed.
Hello Logit, I did search thru some forums and pretty sure I figured out how to save the files with Sensitivity Label = Confidential.....but Im not even sure how I would add that piece to your code. I have tried but keep getting variable not defined. Here is the code I utilized I hope you are able to mesh this with your code to get the saving part to work properly. Definitely let me know if you have any questions. Thank you so much for all your help thus far!
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 & ".xlsx" ''& "_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
' Set the Sensitivity Label
SetSensitivityLabel wb, "Confidential"
' 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
Function SetSensitivityLabel(wb As Workbook, LblName As String)
Dim myLabelInfo As Office.LabelInfo
Dim Context As Variant
Dim objWorkbook As Workbook
Dim CurLabelID As String
Dim sPublic As String
Dim sGeneral As String
Dim sInternal_Use As String
Dim sConfidential As String
Dim sRestricted As String
Set objWorkbook = wb
Set myLabelInfo = objWorkbook.SensitivityLabel.CreateLabelInfo()
Set Context = CreateObject("Scripting.Dictionary")
sPublic = "174b6716-c2ea-4041-b631-5633733fbe46-8420s"
sInternal_Use = "1f9c9bcd-f315-4c3b-87a0-7682e230e7e4-8420z"
sConfidential = "eb0be65c-43df-47d1-8c45-69f1d3d476a9-8420p"
sRestricted = "48d9d89d-06ce-4535-b1a5-059e3329e9c8-8420n"
Select Case LblName
Case "General"
CurLabelID = sGeneral
Case "Public"
CurLabelID = sPublic
Case "Internal Use"
CurLabelID = sInternal_Use
Case "Confidential"
CurLabelID = sConfidential
Case "Restricted"
CurLabelID = sRestricted
End Select
With myLabelInfo
.AssignmentMethod = MsoAssignmentMethod.PRIVILEGED '1
.ContentBits = 4
.IsEnabled = True
.Justification = "Because" 'Make this whatever you want
.LabelId = CurLabelID
.LabelName = LblName
.SetDate = Now()
End With
objWorkbook.SensitivityLabel.SetLabel myLabelInfo, Context
End FunctionI get this error:
Function SetSensitivityLabel(wb As Workbook, LblName As String)
Dim myLabelInfo As Office.LabelInfo
Dim Context As Variant
Dim objWorkbook As Workbook
Dim CurLabelID As String
Dim sPublic As String
Dim sGeneral As String
Dim sInternal_Use As String
Dim sConfidential As String
Dim sRestricted As String
Set objWorkbook = wb
Set myLabelInfo = objWorkbook.SensitivityLabel.CreateLabelInfo()
Context = Nothing ' Set context to Nothing
sPublic = "174b6716-c2ea-4041-b631-5633733fbe46-8420s"
sInternal_Use = "1f9c9bcd-f315-4c3b-87a0-7682e230e7e4-8420z"
sConfidential = "eb0be65c-43df-47d1-8c45-69f1d3d476a9-8420p"
sRestricted = "48d9d89d-06ce-4535-b1a5-059e3329e9c8-8420n"
Select Case LblName
Case "General"
CurLabelID = sGeneral
Case "Public"
CurLabelID = sPublic
Case "Internal Use"
CurLabelID = sInternal_Use
Case "Confidential"
CurLabelID = sConfidential
Case "Restricted"
CurLabelID = sRestricted
End Select
With myLabelInfo
.AssignmentMethod = MsoAssignmentMethod.PRIVILEGED '1
.ContentBits = 4
.IsEnabled = True
.Justification = "Because" 'Make this whatever you want
.LabelId = CurLabelID
.LabelName = LblName
.SetDate = Now()
End With
objWorkbook.SensitivityLabel.SetLabel myLabelInfo, Context
End FunctionI hadnt shown you this message before, but this is the reason I need the sensitivity label satisfied. Thanks
