基于其他单元格值锁定指定单元格（VBA代码问题）

原代码存在三个核心问题导致锁定失效：

• 未指定Range所属工作表，默认指向活动表而非新建的工作簿工作表
• 仅设置Locked=True但未启用工作表保护，单元格锁定不会生效
• 错误用原工作表行号i匹配新建工作表的行，筛选复制后的行号与原行号不对应

修正后的代码 #

Sub ABCD()
    Application.ScreenUpdating = False

    Dim data_sh As Worksheet
    Set data_sh = ThisWorkbook.Sheets("1234")

    Dim setting_sh As Worksheet
    Set setting_sh = ThisWorkbook.Sheets("5678")

    Dim nwb As Workbook
    Dim nsh As Worksheet
    Dim lastRow As Long
    Dim rng As Range

    ' 获取唯一NAME
    setting_sh.Range("A:A").Clear
    data_sh.AutoFilterMode = False
    data_sh.Range("C:C").Copy setting_sh.Range("A1")
    setting_sh.Range("A:A").RemoveDuplicates 1, xlYes

    Dim i As Integer
    For i = 2 To Application.CountA(setting_sh.Range("A:A"))
        data_sh.UsedRange.AutoFilter 3, setting_sh.Range("A" & i).Value

        Set nwb = Workbooks.Add
        Set nsh = nwb.Sheets(1)

        ' 复制可见区域到新表
        data_sh.UsedRange.SpecialCells(xlCellTypeVisible).Copy nsh.Range("A1")
        nsh.Columns("A:U").AutoFit
        
        ' 遍历新表P列，找到值为ERROR的行
        lastRow = nsh.Cells(nsh.Rows.Count, "P").End(xlUp).Row
        For Each rng In nsh.Range("P2:P" & lastRow)
            If UCase(rng.Value) = "ERROR" Then
                ' 锁定对应Q列单元格
                nsh.Range("Q" & rng.Row).Locked = True
            End If
        Next rng
        
        ' 启用工作表保护（可设置密码，这里留空）
        nsh.Protect Password:="", UserInterfaceOnly:=True
        
        ' 保存并关闭新工作簿（替换为你的保存路径）
        nwb.SaveAs "你的保存路径\" & setting_sh.Range("A" & i).Value & ".xlsx"
        nwb.Close False
        
        data_sh.AutoFilterMode = False
    Next i

    setting_sh.Range("A:A").Clear
    Application.ScreenUpdating = True
End Sub

关键修正点说明 #

1. 指定工作表对象：所有Range操作都明确加上nsh.前缀，确保操作的是新建工作簿的工作表
2. 遍历新表行：通过lastRow获取新表实际数据行，遍历P列找到"ERROR"的单元格，匹配对应Q列行号
3. 启用工作表保护：添加nsh.Protect，UserInterfaceOnly:=True确保后续VBA操作仍能修改单元格，仅用户界面锁定
4. 统一大小写判断：用UCase()避免大小写差异导致的判断失效

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