VBA code for additional worksheet protections

BeachDog_2600

New Member
Joined
Feb 4, 2025
Messages
2
Office Version
  1. 365
Platform
  1. Windows
I am trying to add additional protections to a workbook that multiple users use and some of those users are not that great with technology. I'm running into an issue by using workbook/worksheet protections because I need everyone to be able to input data, but the inexperienced users are screwing up the worksheet by copying and pasting cells that have data validation drop downs and tooltips. I'm noticing that errors keep happening even after trying to help those users understand, but I'm thinking that improving the workbook with VBA code might be the best solution. I'm not very familiar with VBA code, but I'm taking some classes on LinkedIn learning to become more familiar (any suggestions on other resources for learning would be much appreciated.)

What I'm trying to do is create a VBA code that does the following:
  1. When the workbook is opened, I want the data to automatically sort the table (columns A-AL) on Sheet1 (LOA) ascending based on Employee Name.
  2. Is it possible to automatically add a row (which includes all of the data validation/dropdowns from the rest of the table) to Table1 if there is data in the current last row or would I just need to make sure the table is large enough to accommodate additional employee rows?
  3. I want columns A-B & H-AL to be locked unless a selection has been made in the dropdown for Column C (Employee Name).
    1. When opening the workbook, Columns A-B & H-AL should already be unlocked if column C (Employee Name) is not blank.
    2. Columns D-G should remain locked so users can’t mess up the formulas.
  4. I would like the following columns to be automatically pulled from Sheet2 (Reference) depending on the data selected in Employee Name (which will use the Employee Name list on Sheet2 (Reference) for data validation). I'm not sure if XLookUP or if Index would be best for this.
    1. Column D – Emp ID
    2. Column E – Employment Condition
    3. Column F – Reports To
    4. Column G – DID
  5. The data on Sheet2 (Reference) won’t always include the same number of employees so if the formulas for Emp ID, Employment Condition, Reports To, DID, and the data validation for Employee Name can automatically extend down to the last row of data that would be great.
    1. I will be updating the data on Sheet2 biweekly, but I don't want anyone else to change it so I'd like it to remain locked unless I unlock it.
  6. Would it be possible to restrict users from cut/copy/paste any of the cells in Columns A-C, P, U, and AB (those are the cells with data validation)? If not, could I set it up so users receiving an error message when they go to cut/copy/paste?
  7. Instead of using filters, I was hoping to insert slicers at the top so users can automatically filter based on 'Status', 'Trans Rep', and 'Employee Name'.
I have been trying all kinds of things to get this to work (even asking AI), but it keeps giving me code with errors and will eventually loop back to errors we've already fixed. That's why I want to learn more about VBA so I'm able to identify issues myself and correct them instead of having to rely on AI to be the expert.

Thank you so much and I really appreciate any insight you can give.

LOA Spreadsheet.xlsx
ABCDEFGHIJKLMNOPQRSTUVWXYZAAABACADAEAFAGAHAIAJAKAL
1
2
3
4
5
6
7
8StatusTrans RepEmployee NameEmp IDEmployment ConditionReports ToDIDFMLAPPLMN P&PParenthoodMed.Mil. (Paid)Mil.UNC Svs.Leave TypeAnticipated Leave Start Date Actual Leave Start Date Anticipated Leave Return DateActual Leave Return DateShort Term DisabilityPPL Start DatePPL End DatePPL Exp. DateNotes (No private medical information)LOA Request Form ReceivedDate Leave Req.RTW/Fitness for Duty RequiredDate RTW/ Fitness for Duty Rec'dInt. Coms for FY 2025 Sent on Date Rights & Resp SentProv. Leave GrantedDate Prov. Leave GrantedCert Req.Date Cert Rec'dFMLA ApprovedDesignation DateDate of Birth
9PendingShaunThomas,Bill2Part-TimeXavier,CharlesB04Z002XXContinuous
10InactiveJulieSmith,Jack1Full-TimeGray,JeanB04Z001
11ActiveSamPaulson,John3IntermittRosenberg,WillowB04Z003
12ActiveBeckySamuelson,Sammy7IntermittMeyers,SethB04Z007
13InactiveJulieJacobson,Zach4Full-TimePryce,WesleyB04Z004
14PendingBeckyGiles,Rupert6Full-TimeKimmel,JimmyB04Z006
15PendingShaunSummer,Buffy5Full-TimeHolmes,PeteB04Z005
16
LOA
Cells with Conditional Formatting
CellConditionCell FormatStop If True
AE9:AL29Expression=MOD(ROW(),2)textNO
Cells with Data Validation
CellAllowCriteria
F9:F16Any value
C8Any value
D8Any value
E8Any value
F8Any value
G8Any value
H8Any value
I8Any value
J8Any value
K8Any value
L8Any value
M8Any value
N8Any value
O8Any value
A9:A15ListPending,Active,Inactive
U9:U16ListN/A,Yes,No
P8Any value
P9:P40ListContinuous,Intermittent,Cont. & Int.,Reduced Schedule
AB9:AB16ListYes,No
B9:B40ListSam,Julie,Shaun,Becky
C9:C40List=References!$A$2:$A$8
D9:D40Any value
 

Excel Facts

Links? Where??
If Excel says you have links but you can't find them, go to Formulas, Name Manager. Look for old links to dead workbooks & delete.
Update -

After a lot of trial and error, I was able to create code that would work. The only thing I can't figure out is how to have a warning message pop up when a user attempts to delete information in a call located in Column C that will let them proceed if needed, but also delete all of the information located in that row (excluding the data validation and formatting). Any help for this issue and/or feedback on my code would be greatly appreciated!

My current code is below:

VBA Code:
Private Sub Workbook_Open()
    Dim ws As Worksheet
    Dim wsRef As Worksheet
    Dim lastRow As Long
    Dim lastRowRef As Long
    
    ' Set worksheet references
    Set ws = ThisWorkbook.Sheets("LOA")
    Set wsRef = ThisWorkbook.Sheets("References")
    
    ' Unprotect workbook and sheets
    ThisWorkbook.Unprotect "123456"
    ws.Unprotect "123456"
    wsRef.Unprotect "123456"
    
    ' Sort data on LOA sheet
    lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
    ws.Sort.SortFields.Clear
    ws.Sort.SortFields.Add Key:=ws.Range("C9:C" & lastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ws.Sort
        .SetRange ws.Range("A9:AL" & lastRow)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    ' Set up data validation for Employee Name
    lastRowRef = wsRef.Cells(wsRef.Rows.Count, "A").End(xlUp).Row
    With ws.Range("C9:C" & lastRow).Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:="=References!$A$2:$A$" & lastRowRef
    End With
    
    ' Set formulas for columns D-G
    ws.Range("D9:D" & lastRow).Formula = "=VLOOKUP(C9,References!$A$2:$G$" & lastRowRef & ",2,FALSE)"
    ws.Range("E9:E" & lastRow).Formula = "=VLOOKUP(C9,References!$A$2:$G$" & lastRowRef & ",3,FALSE)"
    ws.Range("F9:F" & lastRow).Formula = "=VLOOKUP(C9,References!$A$2:$G$" & lastRowRef & ",4,FALSE)"
    ws.Range("G9:G" & lastRow).Formula = "=VLOOKUP(C9,References!$A$2:$G$" & lastRowRef & ",5,FALSE)"
    
    ' Find the last row with data in column C
    lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
    
    ' Set the range for column C
    Set dataRange = ws.Range("C1:C" & lastRow)
    
    ' Loop through each cell in column C
    For Each cell In dataRange
        If Not IsEmpty(cell) Then
            ' Unlock corresponding cells in A, B, and H-AL
            ws.Range("A" & cell.Row & ":B" & cell.Row).Locked = False
            ws.Range("H" & cell.Row & ":AL" & cell.Row).Locked = False
        Else
            ' Lock corresponding cells in A, B, and H-AL
            ws.Range("A" & cell.Row & ":B" & cell.Row).Locked = True
            ws.Range("H" & cell.Row & ":AL" & cell.Row).Locked = True
        End If
    Next cell
    
    ws.Range("C9:C" & lastRow).Locked = False
    
    ' Protect LOA sheet
    ws.Protect "123456", UserInterfaceOnly:=True, AllowFiltering:=True, AllowSorting:=True
    
    ' Protect References sheet
    wsRef.Protect "123456"
    
    ' Protect workbook
    ThisWorkbook.Protect "123456"
End Sub

Option Explicit

Private Const WARNING_MESSAGE As String = "Warning: You are attempting to {0} data." & vbNewLine & _
    "That is not allowed in this spreadsheet. Please press 'ESC' to return to your work."

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo ErrorHandler
    
    If Not Intersect(Target, Me.Range("C:C")) Is Nothing Then
        Application.EnableEvents = False
        Me.Unprotect "123456"
        
        UpdateCellLockStatus Target
        
        Me.Protect "123456", UserInterfaceOnly:=True, AllowFiltering:=True, AllowSorting:=True
    End If

ExitSub:
    Application.EnableEvents = True
    Exit Sub

ErrorHandler:
    MsgBox "An error occurred: " & Err.Description, vbCritical, "Error"
    Resume ExitSub
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Not Application.CutCopyMode = False Then
        Select Case Application.CutCopyMode
            Case xlCut
                ShowWarningMessage "cut"
            Case xlCopy
                ShowWarningMessage "copy"
        End Select
    End If
End Sub

Private Sub UpdateCellLockStatus(ByVal Target As Range)
    Dim cell As Range
    Dim affectedRange As Range
    
    For Each cell In Intersect(Target, Me.Range("C:C"))
        Set affectedRange = Union(Me.Range("A" & cell.Row & ":B" & cell.Row), _
                                  Me.Range("H" & cell.Row & ":AL" & cell.Row))
        
        affectedRange.Locked = (cell.Value = "")
    Next cell
End Sub

Private Sub ShowWarningMessage(ByVal action As String)
    MsgBox Replace(WARNING_MESSAGE, "{0}", action), vbExclamation + vbOKOnly, "Data Modification Warning"
End Sub

Private Sub Worksheet_Change_Paste(ByVal Target As Range)
    If Not Application.CutCopyMode = False Then
        ShowWarningMessage "paste"
    End If
End Sub

Option Explicit

Sub AddNewRowToTable()
    
    Dim ws As Worksheet
    Dim tbl As ListObject
    Dim table_object_row As ListRow
    
    ' Set references to the worksheet and table
    Set ws = ThisWorkbook.Worksheets("LOA")  ' Replace "Sheet1" with your sheet name
    Set tbl = ws.ListObjects(1)  ' Replace "Table1" with your table name

    ' Unprotect workbook and sheets
    ws.Unprotect "123456"
    
    Set table_object_row = tbl.ListRows.Add
    table_object_row.Range(1, 1).Value = ""
    
    ' Protect LOA sheet
    ws.Protect "123456", UserInterfaceOnly:=True, AllowFiltering:=True, AllowSorting:=True
End Sub
 
Upvote 0

Forum statistics

Threads
1,226,695
Messages
6,192,481
Members
453,727
Latest member
tuong_ng89

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