BeachDog_2600
New Member
- Joined
- Feb 4, 2025
- Messages
- 11
- Office Version
- 365
- Platform
- Windows
Hello!
I'm trying to figure out where I'm going wrong with my code. Basically I want my code to decide what protections to initiate and how to proceed based on the data in column C on the 'LOA' tab. My table starts at A8 (headers) and is dynamic. My code should be allowing user entry from C9 to last row and only allowing users to edit columns A-B & H-O if there is data selected in Column C for that row. I had to adjust some of the ranges and that's where I started receiving the error. My original code allowed users to edit the headers because there was data in C8 so I tried to update the code to prevent that.
My current code is below:
My old code that worked is below:
I'm also trying to add code that will delete all of the data in a row (without removing data validations or formatting) when the data in Column C is deleted. I tried the following code, but I wasn't sure how to implement it.
I'm very much a novice when it comes to VBA, but I love the customizability and am trying to learn more. If you have any other advice it would be very much appreciated!
I'm trying to figure out where I'm going wrong with my code. Basically I want my code to decide what protections to initiate and how to proceed based on the data in column C on the 'LOA' tab. My table starts at A8 (headers) and is dynamic. My code should be allowing user entry from C9 to last row and only allowing users to edit columns A-B & H-O if there is data selected in Column C for that row. I had to adjust some of the ranges and that's where I started receiving the error. My original code allowed users to edit the headers because there was data in C8 so I tried to update the code to prevent that.
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("C8:C" & lastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ws.Sort
.SetRange ws.Range("A8:O" & 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("C9: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-O
ws.Range("A" & cell.Row & ":B" & cell.Row).Locked = False
ws.Range("H" & cell.Row & ":O" & cell.Row).Locked = False
Else
' Lock corresponding cells in A, B, and H-O
ws.Range("A" & cell.Row & ":B" & cell.Row).Locked = True
ws.Range("H" & cell.Row & ":O" & 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)
Dim ws As Worksheet
Dim lastRow As Long
On Error GoTo ErrorHandler
lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
If Not Intersect(Target, Me.Range("C9:C" & lastRow)) 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("C9:C" & lastRow))
Set affectedRange = Union(Me.Range("A" & cell.Row & ":B" & cell.Row), _
Me.Range("H" & cell.Row & ":O" & 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 SubMy old code that worked 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 SubI'm also trying to add code that will delete all of the data in a row (without removing data validations or formatting) when the data in Column C is deleted. I tried the following code, but I wasn't sure how to implement it.
VBA Code:
Option Explicit
Private Const WARNING_MESSAGE_DEL As String = "Warning: You are attempting to delete data in Column C." & vbNewLine & _
"This action will clear the entire row. Do you want to proceed?"
Private Sub Worksheet_BeforeDelete(ByVal Target As Range, Cancel As Boolean)
Dim intersectRange As Range
' Check if the deletion involves Column C
Set intersectRange = Intersect(Target, Me.Columns("C"))
If Not intersectRange Is Nothing Then
If MsgBox(WARNING_MESSAGE_DEL, vbExclamation + vbYesNo, "Deletion Warning") = vbNo Then
Cancel = True
End If
End If
End Sub
Private Sub ClearRowExceptColumnC(ByVal rowNumber As Long)
' Clear cells to the left of Column C
Me.Range("A" & rowNumber & ":B" & rowNumber).ClearContents
' Clear cells to the right of Column C
Me.Range("D" & rowNumber & ":" & Me.Cells(rowNumber, Columns.Count).Address).ClearContents
End SubI'm very much a novice when it comes to VBA, but I love the customizability and am trying to learn more. If you have any other advice it would be very much appreciated!
