Добавление модуля класса в ваш проект VB
Примечание: это будет работать, если у вас есть только одна таблица (listobject) на страницу
Имя класса: cProtectedLO
Option Explicit
' Credits: https://stackoverflow.com/questions/32221328/how-to-protect-a-worksheet-and-unprotect-a-list-object-in-vba
Private Type TTable
Table As ListObject
password As String
End Type
Private this As TTable
Private WithEvents appExcel As Excel.Application
Public Property Set Table(ByVal object As ListObject)
Set this.Table = object
End Property
Public Property Let password(ByVal password As String)
this.password = password
End Property
Private Sub Class_Initialize()
Set appExcel = Excel.Application
End Sub
Private Sub appExcel_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim evalRange As Excel.Range
Dim currentValue As Variant
Set evalRange = this.Table.Range
If Sh Is evalRange.Parent Then
If Target.Row > 1 Then
If Not Intersect(Target.Offset(-1), evalRange) Is Nothing Then
If Intersect(Target, evalRange) Is Nothing Then
' Check if selection is an entire row
If Not Target.Cells.Count = Target.EntireRow.Cells.Count Then
currentValue = Target.Value
Sh.Unprotect password:=IIf(Len(this.password), this.password, Null)
With Application
.EnableEvents = False
.Undo
Target.Value = currentValue
'Sh.Cells.Locked = True
this.Table.DataBodyRange.Locked = False
this.Table.Range(this.Table.Range.Rows.Count, 1).Offset(1, 0).Resize(1, this.Table.ListColumns.Count).Locked = False
.EnableEvents = True
End With
Target.Offset(1).Select
Sh.Protect password:=IIf(Len(this.password), this.password, Null), UserInterfaceOnly:=True, AllowFormattingRows:=True, AllowUsingPivotTables:=True, AllowDeletingRows:=True, AllowInsertingRows:=True
End If
End If
' If user is writing somthing in a row
ElseIf Not Intersect(Target.EntireRow, evalRange) Is Nothing Then
' User has selected a row and begins typing (as the row is unprotected). Undo whatever user is doing
If Sh.ProtectContents = True Then
With Application
.EnableEvents = False
.Undo
.EnableEvents = True
End With
End If
End If
End If
End If
End Sub
Private Sub Class_Terminate()
Set this.Table = Nothing
Set appExcel = Nothing
End Sub
Private Sub appExcel_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
Dim evalRange As Range
Dim IsProtected As Boolean
Set evalRange = this.Table.Range
If Sh Is evalRange.Parent Then
' Check if user is copying / cutting cells and is selecting the entire row
If Target.Row > 1 Then
If Not Intersect(Target.Offset(-1), evalRange) Is Nothing And Application.CutCopyMode = 0 And Target.Cells.Count = Target.EntireRow.Cells.Count Then
' Unlock row if it's at the same listobject range (plus the row below the bottom)
If Not Intersect(Target, evalRange.Resize(evalRange.Cells.Rows.Count + 1, evalRange.Cells.Columns.Count)) Is Nothing Then
IsProtected = False
Else
IsProtected = True
End If
Target.EntireRow.Locked = IsProtected
End If
End If
End If
End Sub
Добавить стандартный модуль Имя модуля: mSecurity
Option Explicit
Public colProtectedTable As Collection
Public Sub ProtectWorkbook(Optional ByVal password As Variant)
Dim lProtectedTable As cProtectedLO
Dim evalSheet As Worksheet
Dim evalListObject As ListObject
' Initialize the collection to store current workbook listobjects
Set colProtectedTable = New Collection
' Loop through all worksheets in current workbook
For Each evalSheet In ThisWorkbook.Worksheets
' If the evaluated worksheet has excel structured tables (listobjects)
If evalSheet.ListObjects.Count > 0 Then
' If it does, loop through all of listobjects
For Each evalListObject In evalSheet.ListObjects
' Initialize the class that handles the protected list objects
Set lProtectedTable = New cProtectedLO
With lProtectedTable
' Add the listobject to the class
Set .Table = evalListObject
' In case it's specified, add the password to the class property
If Not IsMissing(password) Then
.password = password
End If
End With
' In case sheet is protected, unprotect it
evalSheet.Unprotect password:=password
' if the listobject is not empty, unblock its cells
If Not evalListObject.DataBodyRange Is Nothing Then
evalListObject.DataBodyRange.Locked = False
End If
' Unlock cells bellow table (so user can add data and the table auto-expands
evalListObject.Range(evalListObject.Range.Rows.Count, 1).Offset(1, 0).Resize(1, evalListObject.ListColumns.Count).Locked = False
' Add the class to the collection so it remains usable
colProtectedTable.Add Item:=lProtectedTable
Next evalListObject
End If
' Protect current sheet
evalSheet.Protect password:=password, UserInterfaceOnly:=True, AllowFormattingRows:=True, AllowUsingPivotTables:=True, AllowDeletingRows:=True, AllowInsertingRows:=True
' Allow expanding grouped rows and columns
evalSheet.EnableOutlining = True
Next evalSheet
End Sub
Запустить защиту с помощью:
ProtectWorkbook