' Sheet1 VBA Code - Optimized Version
Const SheetPassword As String = "ADG"
Dim SkipColumnBCheck As Boolean
Dim mblnPerformingRowOperation As Boolean
Dim mblnSkipNextChangeEvent As Boolean
Public Sub ProtectSheet()
On Error GoTo ErrorHandler
With Me
.Protect Password:=SheetPassword, UserInterfaceOnly:=True, _
AllowFormattingCells:=True, AllowFormattingColumns:=True, _
AllowFormattingRows:=True, AllowInsertingColumns:=True, _
AllowInsertingRows:=True, AllowInsertingHyperlinks:=True, _
AllowDeletingColumns:=True, AllowDeletingRows:=True, _
AllowSorting:=True, AllowFiltering:=True,
AllowUsingPivotTables:=True
End With
Exit Sub
ErrorHandler:
Debug.Print "ProtectSheet error: " & Err.Description
' Fallback to basic protection
Me.Protect Password:=SheetPassword
End Sub
Public Sub UnprotectSheet()
On Error Resume Next
Me.Unprotect SheetPassword
On Error GoTo 0
End Sub
Public Sub HandleSheetSetup()
Dim ws As Worksheet
Dim cell As Range, tbl As ListObject
Dim lastRow As Long, lastCol As Long
On Error GoTo ErrorHandler
Application.ScreenUpdating = False
UnprotectSheet
Set ws = ThisWorkbook.Sheets("Sheet1")
' Hide Column A and lock Column B
With ws
.Columns("A:A").Hidden = True
.Columns("B:B").Locked = True
' Disable table auto-expansion
Application.AutoCorrect.DisplayAutoCorrectOptions = False
Application.AutoCorrect.AutoExpandListRange = False
' Color header row (A1:E1)
.Range("A1:E1").Interior.Color = RGB(217, 225, 243)
.Range("A1:E1").Locked = True
' Color Column B cells with content
lastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
For Each cell In .Range("B1:B" & lastRow)
cell.Interior.Color = IIf(Trim(cell.Value) <> "", RGB(230, 230, 230),
xlNone)
Next cell
' Highlight non-empty cells from Column C onwards
.Range("C:XFD").Interior.ColorIndex = xlNone
On Error Resume Next
With .Range("C:XFD").SpecialCells(xlCellTypeConstants)
.Interior.Color = RGB(255, 243, 204)
End With
With .Range("C:XFD").SpecialCells(xlCellTypeFormulas)
.Interior.Color = RGB(255, 243, 204)
End With
On Error GoTo 0
' Format tables
For Each tbl In .ListObjects
With tbl
.Range.Interior.Color = RGB(227, 253, 232)
.HeaderRowRange.Interior.Color = RGB(202, 230, 207)
With .Range.Borders
.LineStyle = xlContinuous
.Weight = xlThin
.Color = RGB(0, 0, 0)
End With
End With
Next tbl
End With
CleanUp:
ProtectSheet
Application.ScreenUpdating = True
Exit Sub
ErrorHandler:
MsgBox "Error in HandleSheetSetup: " & Err.Description, vbCritical
Resume CleanUp
End Sub
' ---- Row Operations ----
Public Sub InsertRowsBelow()
Dim ws As Worksheet, tbl As ListObject
Dim selectedRow As Long, numRows As Long, insertAtRow As Long
Dim response As Variant, addInTable As VbMsgBoxResult
On Error GoTo CleanUp
mblnPerformingRowOperation = True
mblnSkipNextChangeEvent = True
Application.ScreenUpdating = False
UnprotectSheet
Set ws = ActiveSheet
' Validate selection
If Selection.Cells.CountLarge > 1 Then
MsgBox "Select a single cell to insert rows below.", vbExclamation
GoTo CleanUp
End If
selectedRow = Selection.Row
If selectedRow < 2 Then
MsgBox "You can't insert rows here!", vbExclamation
GoTo CleanUp
End If
' Check if in table
On Error Resume Next
Set tbl = Selection.ListObject
On Error GoTo CleanUp
If tbl Is Nothing Then
MsgBox "You can only insert rows within table ranges.", vbExclamation
GoTo CleanUp
End If
' Get number of rows to insert
response = InputBox("How many rows to insert below the selected row?", "Insert
Rows", 1)
If Not IsNumeric(response) Or response <= 0 Then
MsgBox "Please enter a valid positive number.", vbExclamation
GoTo CleanUp
End If
numRows = CLng(response)
addInTable = MsgBox("Add the rows within the table?", vbYesNo + vbQuestion,
"Add to Table")
' Insert empty rows below table
insertAtRow = tbl.Range.Row + tbl.Range.Rows.Count
ws.Rows(insertAtRow & ":" & insertAtRow + numRows - 1).Insert Shift:=xlDown
' Resize table if requested
If addInTable = vbYes Then
tbl.Resize tbl.Range.Resize(tbl.Range.Rows.Count + numRows)
With ws.Range(tbl.Range.Cells(tbl.Range.Rows.Count + 1, 1), _
ws.Cells(insertAtRow + numRows - 1,
tbl.Range.Columns.Count)).Borders
.LineStyle = xlContinuous
.Weight = xlThin
.Color = RGB(0, 0, 0)
End With
End If
CleanUp:
mblnPerformingRowOperation = False
mblnSkipNextChangeEvent = False
ProtectSheet
Application.ScreenUpdating = True
End Sub
Public Sub DeleteSelectedRows()
Dim ws As Worksheet
Dim selectedRow As Long, numRows As Long, i As Long
Dim response As Variant, canDelete As Boolean
On Error GoTo CleanUp
mblnPerformingRowOperation = True
mblnSkipNextChangeEvent = True
Application.ScreenUpdating = False
UnprotectSheet
Set ws = ThisWorkbook.Sheets("Sheet1")
' Validate selection
If Selection.Cells.CountLarge > 1 Then
MsgBox "Select a single cell to delete rows.", vbExclamation
GoTo CleanUp
End If
selectedRow = Selection.Row
' Check for template content
If ws.Cells(selectedRow, "A").Value <> "" Then
MsgBox "Template content cannot be deleted.", vbExclamation
GoTo CleanUp
End If
If selectedRow < 2 Then
MsgBox "You can't delete this row", vbCritical
GoTo CleanUp
End If
' Get number of rows to delete
response = InputBox("How many rows to delete?", "Delete Rows", 1)
If Not IsNumeric(response) Or response <= 0 Then
MsgBox "Please enter a valid positive number.", vbExclamation
GoTo CleanUp
End If
numRows = CLng(response)
' Validate row range
If selectedRow + numRows - 1 > ws.Rows.Count Then
MsgBox "You cannot delete beyond the last row!", vbExclamation
GoTo CleanUp
End If
' Check for protected rows
canDelete = True
For i = 0 To numRows - 1
If ws.Cells(selectedRow + i, "A").Value <> "" Then
MsgBox "Template content cannot be deleted from row " & (selectedRow +
i), vbExclamation
canDelete = False
Exit For
End If
Next i
If Not canDelete Then GoTo CleanUp
' Confirm deletion
If MsgBox("Delete " & numRows & " rows starting from row " & selectedRow & "?",
vbYesNo + vbQuestion) = vbNo Then
GoTo CleanUp
End If
' Delete rows
For i = numRows - 1 To 0 Step -1
ws.Rows(selectedRow + i).Delete Shift:=xlUp
Next i
CleanUp:
mblnPerformingRowOperation = False
mblnSkipNextChangeEvent = False
ProtectSheet
Application.ScreenUpdating = True
End Sub
' ---- Worksheet Events ----
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim tbl As ListObject
If mblnPerformingRowOperation Then Exit Sub
' Check if in table data range
On Error Resume Next
Set tbl = Target.ListObject
On Error GoTo 0
If Not tbl Is Nothing And Target.Cells.Count = 1 Then
If IsEmpty(Target.Value) Or Target.Value = "" Then
If Me.ProtectContents Then Me.Unprotect SheetPassword
Exit Sub
End If
End If
' Protect columns A and B
If Not Intersect(Target, Me.Columns("A:B")) Is Nothing Then
MsgBox "Cell " & Target.Address(False, False) & " is not editable (Columns
A and B are protected)", vbInformation
Exit Sub
End If
' Handle protection for single cell selection
If Target.Cells.Count = 1 Then
If Not Me.ProtectContents And (IsEmpty(Target.Value)) Then
Me.Protect SheetPassword
ElseIf Not IsEmpty(Target.Value) Then
If Me.ProtectContents Then Me.Unprotect SheetPassword
End If
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range, showMessage As Boolean, shouldProtect As Boolean
If mblnPerformingRowOperation Or mblnSkipNextChangeEvent Then
mblnSkipNextChangeEvent = False
Exit Sub
End If
If Target.Rows.Count > 1 Or Target.Cells.Count = Me.Rows.Count Then Exit Sub
If SkipColumnBCheck Then Exit Sub
' Prevent changes to columns A and B
If Not Intersect(Target, Me.Columns("A:B")) Is Nothing Then
Application.EnableEvents = False
On Error Resume Next
Application.Undo
On Error GoTo 0
Application.EnableEvents = True
MsgBox "Cannot modify " & Target.Address(False, False) & " - Columns A and
B are protected", vbExclamation
Exit Sub
End If
If Target.Cells.CountLarge > 1 Then Exit Sub
' Validate changes
showMessage = False
shouldProtect = True
For Each cell In Target
' Check protected areas
If Not Intersect(cell, Me.Range("A1:E1")) Is Nothing Then
showMessage = True
MsgBox "Header row cannot be edited!", vbCritical
Exit For
End If
' Determine if protection needed
If Not cell.ListObject Is Nothing Then shouldProtect = False
If cell.Interior.Color = RGB(255, 243, 204) Then shouldProtect = False
Next cell
' Handle protection
If Me.ProtectContents Then Me.Unprotect SheetPassword
If showMessage Then
Application.EnableEvents = False
On Error Resume Next
Application.Undo
On Error GoTo 0
Application.EnableEvents = True
End If
If shouldProtect And Not Me.ProtectContents Then
Me.Protect SheetPassword, UserInterfaceOnly:=True
End If
End Sub
' ---- Utility Functions ----
Public Sub AddBordersToRowsAndColumns()
Dim ws As Worksheet, rng As Range, cell As Range
Dim lastRow As Long, lastCol As Long
On Error GoTo ErrorHandler
Application.ScreenUpdating = False
UnprotectSheet
Set ws = ThisWorkbook.Sheets("Sheet1")
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
lastCol = 11 ' Column K
Set rng = ws.Range("A1").Resize(lastRow, lastCol)
rng.Borders.LineStyle = xlNone
Application.ScreenUpdating = False
For Each cell In rng
If Trim(cell.Value) <> "" Then
With cell.Borders
.LineStyle = xlContinuous
.Weight = xlThin
End With
End If
Next cell
CleanUp:
ProtectSheet
Application.ScreenUpdating = True
Exit Sub
ErrorHandler:
MsgBox "Error in AddBorders: " & Err.Description, vbCritical
Resume CleanUp
End Sub
Public Sub HandleUpdateCurrentDate()
On Error GoTo ErrorHandler
Application.ScreenUpdating = False
UnprotectSheet
ThisWorkbook.Sheets("Sheet1").Range("E4").Value = Date
CleanUp:
ProtectSheet
Application.ScreenUpdating = True
Exit Sub
ErrorHandler:
MsgBox "Error updating date: " & Err.Description, vbCritical
Resume CleanUp
End Sub
Public Sub ValidateTableBeforeSave(ByRef CancelSave As Boolean)
Dim ws As Worksheet, tbl As ListObject
Dim rng As Range, cell As Range
Dim emptyRows As Collection
Dim tblName As String, msg As String
Dim hasErrors As Boolean
Dim i As Long
On Error GoTo ErrorHandler
Application.ScreenUpdating = False
UnprotectSheet
Set ws = ThisWorkbook.Sheets("Sheet1")
Set emptyRows = New Collection
CancelSave = False
hasErrors = False
' Check all tables in the worksheet
For Each tbl In ws.ListObjects
tblName = tbl.Name
Set rng = tbl.DataBodyRange
' Check for completely empty rows in the table
For i = 1 To rng.Rows.Count
If Application.CountA(rng.Rows(i)) = 0 Then
emptyRows.Add tbl.Range.Row + i - 1
hasErrors = True
End If
Next i
' Check for partially filled rows (all cells empty except one)
For Each cell In rng
If Application.CountA(rng.Rows(cell.Row - rng.Row + 1)) = 1 And _
cell.Value = "" Then
emptyRows.Add cell.Row
hasErrors = True
End If
Next cell
Next tbl
' If errors found, show message and cancel save
If hasErrors Then
msg = "Cannot save because the following issues were found:" & vbCrLf &
vbCrLf
msg = msg & "1. Empty rows detected in tables (rows: "
' Build list of empty rows
If emptyRows.Count > 0 Then
For i = 1 To emptyRows.Count
If i > 1 Then msg = msg & ", "
If i > 10 Then
msg = msg & "..."
Exit For
End If
msg = msg & emptyRows(i)
Next i
End If
msg = msg & ")" & vbCrLf & vbCrLf
msg = msg & "Please either:" & vbCrLf
msg = msg & "- Fill in all required data in these rows" & vbCrLf
msg = msg & "- Delete the empty rows completely" & vbCrLf
msg = msg & "- Move the rows outside the table range"
MsgBox msg, vbCritical, "Validation Error"
CancelSave = True
End If
CleanUp:
ProtectSheet
Application.ScreenUpdating = True
Exit Sub
ErrorHandler:
MsgBox "Validation error: " & Err.Description, vbCritical
CancelSave = True
Resume CleanUp
End Sub
