Excel VBA：取消目标工作表保护后执行数据迁移再重保护的问题

原代码核心问题 #

1. 取消保护的Macro1调用位置错误，且未明确针对目标工作表操作
2. 重新保护的Macro2被写在事件过程外部，完全不会执行
3. 新增行未锁定就执行保护，导致新增数据仍可被编辑

修正后的完整代码 #

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rng As Range, c As Range, rngDel As Range
    Dim tblSrc As ListObject, tblDest As ListObject, tName
    Dim wsDest As Worksheet
    Dim newRow As ListRow
    
    ' 绑定目标工作表与表格
    Set wsDest = ThisWorkbook.Worksheets("Revoked Master List")
    Set tblDest = wsDest.ListObjects("RevokedMaster")
    
    ' 遍历所有源表格
    For Each tName In Array("Table15", "Table16", "Table17", "Table18")
        Set tblSrc = Me.ListObjects(tName)
        
        ' 检查修改是否发生在"Date Revoked"列
        Set rng = Application.Intersect(Target, tblSrc.ListColumns("Date Revoked").DataBodyRange)
        If Not rng Is Nothing Then
            On Error GoTo haveError
            Application.ScreenUpdating = False
            Application.EnableEvents = False
            
            ' 1. 取消目标工作表保护（有密码则替换为空字符串）
            wsDest.Unprotect Password:=""
            
            For Each c In rng.Cells
                If IsDate(c.Value) Then
                    ' 复制源行到目标表格
                    Set newRow = tblDest.ListRows.Add()
                    Application.Intersect(c.EntireRow, tblSrc.DataBodyRange).Copy
                    newRow.Range.PasteSpecial xlPasteValuesAndNumberFormats
                    
                    ' 2. 锁定新增行的所有单元格
                    newRow.Range.Locked = True
                    
                    ' 标记源表待删除行
                    BuildRange rngDel, c
                End If
            Next c
            
            ' 删除源表标记行
            If Not rngDel Is Nothing Then rngDel.EntireRow.Delete
            Set rngDel = Nothing
            
            ' 3. 重新保护目标工作表，保留VBA操作权限并允许表格扩展
            wsDest.Protect Password:="", UserInterfaceOnly:=True, AllowInsertingRows:=True
            
        End If
    Next tName

haveError:
    If Err.Number <> 0 Then Debug.Print Err.Description
    ' 恢复系统设置
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

' 合并待删除范围的辅助子程序
Sub BuildRange(ByRef rngTot As Range, rngAdd As Range)
    If rngTot Is Nothing Then
        Set rngTot = rngAdd
    Else
        Set rngTot = Application.Union(rngTot, rngAdd)
    End If
End Sub

关键修改说明 #

• 直接控制保护逻辑：放弃单独宏，直接在事件过程中调用目标工作表的Unprotect/Protect，避免作用域问题
• 锁定新增行：复制完成后立即锁定新增行单元格，确保保护后无法编辑
• 保留VBA操作权限：使用UserInterfaceOnly:=True参数，保护后VBA仍可操作表格，无需每次重复取消保护
• 允许表格扩展：添加AllowInsertingRows:=True，保证ListObject能正常新增行
• 值粘贴优化：用xlPasteValuesAndNumberFormats避免格式冲突和保护权限问题

注意事项 #

• 若目标工作表有保护密码，将Password:=""替换为实际密码
• UserInterfaceOnly参数在工作簿重启后会失效，可在Workbook_Open事件中重新执行一次保护逻辑确保生效
• 确认源表的"Date Revoked"列名、目标表名称与代码完全一致

内容的提问来源于stack exchange，提问作者Jphillip82