用VB实现特定单元格修改的密码提示

jady999

如图，
因为公司每天都有数据录入，日期我是用VB自动生成的。
现在的问题是：假设今天日期是16-1-15 。除了今天录的那一行可以修改外。其他的今天之前日期的那些行，都是不可以删除修改，要删除修改会提示一个输入密码框，密码是123。输入密码后可以修改。不然不可以修改资料。
多谢大家的查看和意见。

lichuanboy44

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Locked And Sheets(1).ProtectContents And Target.Count = 1 Then
        ps = InputBox("本单元格已被锁定，如修改或删除数据，请输入解锁密码")
        If ps <> "123" Then
            MsgBox "解锁密码错误，无权限修改"
            Exit Sub
        Else
            Sheets(1).Protect Password:="123", DrawingObjects:=True, Contents:=True, Scenarios:=True _
                                 , AllowFiltering:=True
        End If
    End If
End Sub

Private Sub Worksheet_Deactivate()
'一旦点击本表之外的其它表或关闭工作簿，则触发此事件，即将本表中数据全部锁定，并保护工作表
    Sheets(1).Unprotect "123"
    n = [A65536].End(3).Row: ar = Range("A2:A" & n)
    For i = 1 To n - 1
       s = ar(i, 1)
       d1 = VBA.CDate(Year(s) & "-" & Month(s) & "-" & Day(s))
       d2 = Date
       If d1 = d2 Then
          p = i
          Exit For
       End If
   Next
    Rows("1:" & 5000).Locked = False
    Rows("1:" & p).Locked = True
    Sheets(1).Protect Password:="123", DrawingObjects:=True, Contents:=True, Scenarios:=True _
                         , AllowFiltering:=True
End Sub

JX_shangrila

Private Sub Worksheet_Change(ByVal Target As Range)
   On Error Resume Next
   Application.EnableEvents = False
   Application.ScreenUpdating = False
   dz = Target.Address
   ActiveSheet.Unprotect "111"
   d = Range("a:a").Find(Date, LookIn:=xlFormulas).Address
   If d = "" Then r = Cells(Rows.Count, 1).End(xlUp).Row + 1 Else r = Val(Split(d, "$")(2))
   Range("a" & r & ":iv65536").Select
   Selection.Locked = False
   Selection.FormulaHidden = False
   Range("a1:iv" & r - 1).Select
   Selection.Locked = True
   Selection.FormulaHidden = True
   ActiveSheet.Protection.AllowEditRanges(1).Delete
   ActiveSheet.Protection.AllowEditRanges.Add Title:="区域1", Range:=Range("a" & r & ":iv65536")
   ActiveSheet.Protect "111"
   Range(dz).Select
   Application.EnableEvents = True
   Application.ScreenUpdating = True
End Sub

jady999

lichuanboy44 发表于 2016-1-15 12:14
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Locked And Sheets(1).Pro ...

我发现您给我的附件写的和我想的要求差不多。
不过，有个问题是：日期是指今天以前的整行都加密且不可以修改，假如是今天的日期就整行可以修改。是用VB实现的。我发现你附件里面虽然会提示不可修改，但是点完弹出框，按删除键，还是可以删掉资料。

lichuanboy44

jady999 发表于 2016-1-16 13:18
我发现您给我的附件写的和我想的要求差不多。
不过，有个问题是：日期是指今天以前的整行都加密且不可以 ...

     我重新新建了一个工簿，同样的语句，同样的处理，成功了，见附件。
     不过我还有一点没明白，我把你的有关相机的数据通过“移动复制工作表”的办法全部（带格式）复制到新建的工作簿，当点击对话框，密码未输入的情况下，同样出现可用delete删除数据的情况（仅限AB两列可删除或清除）；但我把你原有数据通过选择性粘贴文本的方式复制过去后，再把程序语句复制过去，又正常。违反常理，没时间探讨。成功了，能用就用吧，不知你原来的数据有什么奥妙。