[已解决]求助高手：启用“保护工作表”功能后，在B列输入商品编号，不能调出相应的数据

horriman

启用“保护工作表”功能后，在B列输入商品编号，不能调出相应的数据

最佳答案

月排行榜 / 总排行榜

mxg825

2011-6-5 14:45

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2. Application.EnableEvents = False
   
3. Sheets(1).Unprotect Password:=123 '密码为“123”  打开工作表
   
4. '中间是你的程序过程
   
5. 
   
6.   Sheets(1).Protect Password:=123    '重新用密码保护工作表
   
7. Application.EnableEvents = True
   
8. 
   
9. End Sub
   

复制代码

跳转到最佳答案楼层

mxg825

你的调出相应数据是用VBA
保护工作表

需要要代码中 增加两句代码
先解除 保护
你的过程。。。。
再增加 保护

mxg825

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2. Application.EnableEvents = False
   
3. Sheets(1).Unprotect Password:=123 '密码为“123”  打开工作表
   
4. '中间是你的程序过程
   
5. 
   
6.   Sheets(1).Protect Password:=123    '重新用密码保护工作表
   
7. Application.EnableEvents = True
   
8. 
   
9. End Sub
   

复制代码

horriman

回复 mxg825 的帖子

代码放到里面了，还是不行的，请帮我检查一下

Public bl As Boolean
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Resume Next
Application.EnableEvents = False     '关闭单元格事件
Sheets(1).Unprotect Password:=123
    If Target.Count = 1 Then        '如果选择的只有一个单元格
        If Target.Column = 2 And Target.Value = "" Then '选择的是第一列并且该单元格为空,则写入日期
            Target(1, 0).Value = Application.Text(Now(), "yyyy-mm-dd   hh:mm:ss")
        Else    '否则记录该单元格的值
            K = Target.Value
        End If
    Else    '如果选择的是多个单元格,则选择A1单元格
        [a1].Select
        K = [a1]
    End If

'If bl = False Then
'    If Target <> "" Then
'    Cells(Target.Row + 1, Target.Column).Select
'    Else
'    Exit Sub
'    End If
'Else
'    Exit Sub
'End If
Sheets(1).Protect Password:=123
Application.EnableEvents = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
On Error Resume Next
    Dim rng As Range
    Set rng = Sheets(3).Range("A:A").Find(Target, , , 1)
    If Not rng Is Nothing Then
        
        Target = rng.Offset(0, 1)
    End If
   
    Dim Arr
    If Target.Column = 2 Then
        If Len(Target.Value) > 0 Then
            row1 = Sheet2.Range("a65536").End(xlUp).Row
            Arr = Sheet2.Range("a2:D" & row1)
            For hx = 1 To UBound(Arr)
                If Arr(hx, 1) = Target.Value Then
                    Target.Offset(0, 1) = Arr(hx, 2)
                    Target.Offset(0, 2) = Arr(hx, 3)
                    Target.Offset(0, 3) = Arr(hx, 4)
                End If
            Next
        Else
            Target.Resize(, 4).ClearContents
        End If
    End If
            Application.EnableEvents = True
End Sub

mxg825

你放错了！
应该是下面那个事件（单元格修改事件  Worksheet_Change）

那么的帅

回复 horriman 的帖子

出货登记表-2.rar (38.62 KB, 下载次数: 16)

2011-6-5 15:14 上传

点击文件名下载附件