为现有Excel VBA代码添加单元格区域锁定 保留可编辑区且不影响VBA运行

核心实现逻辑 #

解决该需求只需要处理三个核心要点：

• 不硬编码工作表名称：在工作表事件代码中使用Me关键字指代当前代码所属的工作表，代码迁移到任意工作表都可直接生效，不需要修改表名引用。
• 保护工作表不阻断VBA运行：启用工作表保护时添加UserInterfaceOnly:=True参数，该模式下保护规则仅对用户手动操作生效，VBA代码修改单元格不受任何限制，无需反复解锁/重锁工作表。
• 单元格锁定规则：Excel默认所有单元格为锁定状态，只需要将指定可编辑区域的Locked属性设为False，开启保护后其余区域自动锁定，无法手动编辑。

操作步骤 #

• 按Alt+F11打开VBA编辑器，在左侧工程栏双击需要实现功能的工作表，打开代码编辑窗口。
• 清空窗口内原有旧代码，粘贴下方修改完成的完整代码。
• 保存文件为启用宏的工作簿格式（*.xlsm），重新打开文件即可生效。

完整VBA代码 #

Private Sub Worksheet_Activate()
    ' 工作表激活时自动配置锁定规则与保护，无需手动操作
    Dim editableRng As Range
    ' 关闭屏幕更新提升运行速度
    Application.ScreenUpdating = False
    
    ' 先锁定所有单元格
    Me.Cells.Locked = True
    ' 合并所有允许编辑的区域
    Set editableRng = Union(Me.Range("A13:A377"), Me.Range("B1"), Me.Range("D3:D4"), _
                            Me.Range("D13:D377"), Me.Range("F13:I377"))
    ' 解锁指定的可编辑区域
    editableRng.Locked = False
    
    ' 启用仅限制用户操作的工作表保护，VBA运行不受影响
    Me.Protect UserInterfaceOnly:=True, DrawingObjects:=True, Contents:=True, Scenarios:=True
    
    Application.ScreenUpdating = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
' 实现下拉列表无重复多选功能
Dim Oldvalue As String
Dim Newvalue As String
Application.EnableEvents = True
On Error GoTo Exitsub
If Target.Column = 1 Then
  If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
    GoTo Exitsub
  Else
    If Target.Value = "" Then GoTo Exitsub Else
    Application.EnableEvents = False
    Newvalue = Target.Value
    Application.Undo
    Oldvalue = Target.Value
      If Oldvalue = "" Then
        Target.Value = Newvalue
      Else
        If InStr(1, Oldvalue, Newvalue) = 0 Then
            Target.Value = Oldvalue & " & " & Newvalue
      Else
        Target.Value = Oldvalue
      End If
    End If
  End If
End If
Application.EnableEvents = True
Exitsub:
Application.EnableEvents = True
End Sub

补充说明 #

• 如果需要设置保护密码，可以在Me.Protect行添加Password:="你设置的密码"参数即可，不会影响VBA正常运行。
• 代码中Worksheet_Activate事件会在每次切换到该工作表时自动校验锁定规则和保护状态，不需要手动重复配置。
• 原有下拉多选的逻辑完全保留，没有做功能改动。

内容的提问来源于stack exchange，提问作者omg.sista