Need Help Applying Sensitivity Label to My Current VBA Code

RyanHawkeye

New Member
Joined
Apr 9, 2015
Messages
46
I need the following code to automatically overwrite the old file without it popping up the spreadsheet to manually ask me if I want to overwrite the spreadsheet. Another important part I need is the Sensitivity Lable to show as "Confidential" prior to saving the Spreadsheets. Below is what code I have so far. Any help will be very much appreciated. Thanks! :)

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
 

Excel Facts

Test for Multiple Conditions in IF?
Use AND(test, test, test, test) or OR(test, test, test, ...) as the logical_test argument of IF.
See if the post in the link below helps (please note that I can't amend it as I am not at work to be able to test it)

 
Upvote 0
Hi Mark, I was able to find a code that would change the Sensitivity Label of my Spreadsheet. But Im not a VBA expert and Im not sure how I can incorporate the code below with my code above. Hopefully you are able to help with this.

/**** The code right below sets up the use of the very last small code to set the Sensitivity Label ****/

'WB: The workbook you want to change the Sensitivity on

'LblName: General

' Public

' Internal Use

' Confidential

' Restricted

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 = ActiveWorkbook

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 Function



/*** The below Part identifies the Sensitivity IDs for Public, Internal Use, Confidential, and Restricted ****/

Sub GetSensitivityID()

Dim myLabelInfo As Office.LabelInfo

Set myLabelInfo = ActiveWorkbook.SensitivityLabel.GetLabel()

Debug.Print myLabelInfo.LabelId



End Sub

/****** The below will change the Label of the Spreadsheet to what you want it to be ****/

Sub SetSLabel()

SetSensitivityLabel ActiveWorkbook, "Confidential"

End Sub
 
Upvote 0

Forum statistics

Threads
1,226,463
Messages
6,191,181
Members
453,646
Latest member
BOUCHOUATA

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