Piny-設置下述防呆機制(VBA)

蓝桥玄霜

1. Private Sub Workbook_BeforeClose(Cancel As Boolean)
   
2. Application.CommandBars("Cell").Controls("粘贴(&P)").Enabled = True
   
3. Application.CommandBars("Cell").Controls("选择性粘贴(&S)...").Enabled = True
   
4. Application.CommandBars(1).Controls("编辑(&E)").Controls("粘贴(&P)").Enabled = True
   
5. Application.CommandBars(1).Controls("编辑(&E)").Controls("选择性粘贴(&S)...").Enabled = True
   
6. Application.CommandBars(1).Controls("编辑(&E)").Controls("office 剪贴板(&B)...").Enabled = True
   
7. Application.CommandBars(3).Controls("粘贴(&P)").Enabled = True
   
8. Application.CommandBars.DisableCustomize = False
   
9. Application.CommandBars(1).Controls("工具(&T)").Controls("自定义(&C)...").Enabled = True
   
10. Application.OnKey "^v"
    
11. End Sub
    
12. 
    
13. Private Sub Workbook_Open()
    
14. Sheet11.CommandButton2.Visible = True
    
15. Sheet11.CommandButton1.Visible = False
    
16. End Sub
    
17. 
    
18. 
    
19. Private Sub Workbook_SheetActivate(ByVal Sh As Object)
    
20. If Sh.Name <> "result" Then
    
21. Application.CommandBars("Cell").Controls("粘贴(&P)").Enabled = True
    
22. Application.CommandBars("Cell").Controls("选择性粘贴(&S)...").Enabled = True
    
23. Application.CommandBars(1).Controls("编辑(&E)").Controls("粘贴(&P)").Enabled = True
    
24. Application.CommandBars(1).Controls("编辑(&E)").Controls("选择性粘贴(&S)...").Enabled = True
    
25. Application.CommandBars(1).Controls("编辑(&E)").Controls("office 剪贴板(&B)...").Enabled = True
    
26. Application.CommandBars(3).Controls("粘贴(&P)").Enabled = True
    
27. Application.CommandBars.DisableCustomize = False
    
28. Application.CommandBars(1).Controls("工具(&T)").Controls("自定义(&C)...").Enabled = True
    
29. Application.OnKey "^v"
    
30. Else
    
31. Application.CommandBars("Cell").Controls("粘贴(&P)").Enabled = False
    
32. Application.CommandBars("Cell").Controls("选择性粘贴(&S)...").Enabled = False
    
33. Application.CommandBars(1).Controls("编辑(&E)").Controls("粘贴(&P)").Enabled = False
    
34. Application.CommandBars(1).Controls("编辑(&E)").Controls("选择性粘贴(&S)...").Enabled = False
    
35. Application.CommandBars(1).Controls("编辑(&E)").Controls("office 剪贴板(&B)...").Enabled = False
    
36. Application.CommandBars(3).Controls("粘贴(&P)").Enabled = False
    
37. Application.CommandBars.DisableCustomize = True
    
38. Application.CommandBars(1).Controls("工具(&T)").Controls("自定义(&C)...").Enabled = False
    
39. Application.OnKey "^v", ""
    
40. 
    
41. End If
    
42. 
    
43. End Sub
    
44. 
    

复制代码

蓝桥玄霜

请见附件。

piny

以23樓測試 問題如下

有一句代碼不確定是對應繁体版哪一個功能，改成「貼上」亦會運行錯誤，但將此句成為註解，則可順利關閉此檔。

故想請問是否可將此動作擷圖，俾利對應

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.CommandBars("Cell").Controls("貼上(&P)").Enabled = True
Application.CommandBars("Cell").Controls("選擇性貼上(&S)...").Enabled = True
Application.CommandBars(1).Controls("編輯(&E)").Controls("貼上(&P)").Enabled = True
Application.CommandBars(1).Controls("編輯(&E)").Controls("選擇性貼上(&S)...").Enabled = True
Application.CommandBars(1).Controls("編輯(&E)").Controls("office 剪貼簿(&B)...").Enabled = True
'Application.CommandBars(3).Controls("貼上(&P)").Enabled = True
Application.CommandBars.DisableCustomize = False
Application.CommandBars(1).Controls("工具(&T)").Controls("自訂(&C)...").Enabled = True
Application.OnKey "^v"
End Sub

Private Sub Workbook_Open()
Sheet11.CommandButton2.Visible = True
Sheet11.CommandButton1.Visible = False
End Sub


Private Sub Workbook_SheetActivate(ByVal Sh As Object)
If Sh.Name <> "result" Then
Application.CommandBars("Cell").Controls("貼上(&P)").Enabled = True
Application.CommandBars("Cell").Controls("選擇性貼上(&S)...").Enabled = True
Application.CommandBars(1).Controls("編輯(&E)").Controls("貼上(&P)").Enabled = True
Application.CommandBars(1).Controls("編輯(&E)").Controls("選擇性貼上(&S)...").Enabled = True
Application.CommandBars(1).Controls("編輯(&E)").Controls("office 剪貼簿(&B)...").Enabled = True
'Application.CommandBars(3).Controls("貼上(&P)").Enabled = True
Application.CommandBars.DisableCustomize = False
Application.CommandBars(1).Controls("工具(&T)").Controls("自訂(&C)...").Enabled = True
Application.OnKey "^v"
Else
Application.CommandBars("Cell").Controls("貼上(&P)").Enabled = False
Application.CommandBars("Cell").Controls("選擇性貼上(&S)...").Enabled = False
Application.CommandBars(1).Controls("編輯(&E)").Controls("貼上(&P)").Enabled = False
Application.CommandBars(1).Controls("編輯(&E)").Controls("選擇性貼上(&S)...").Enabled = False
Application.CommandBars(1).Controls("編輯(&E)").Controls("office 剪貼簿(&B)...").Enabled = False
'Application.CommandBars(3).Controls("貼上(&P)").Enabled = False
Application.CommandBars.DisableCustomize = True
Application.CommandBars(1).Controls("工具(&T)").Controls("自訂(&C)...").Enabled = False
Application.OnKey "^v", ""

End If

End Sub

[ 本帖最后由 piny 于 2011-8-1 09:24 编辑 ]

piny

還有兩個有效清單的問題

B7之清單應為「是」與「否」，請問應如何修正

B8之清單尚包含「否」，請問應如何修正

蓝桥玄霜

1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
2. Dim aa, i&, r1
   
3. If Target.Address = "$H$1" Then
   
4. ActiveSheet.Unprotect
   
5. Call sjyxx
   
6.     ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
   
7.         , AllowFiltering:=True
   
8. 
   
9. ElseIf Target.Address = "$B$3" Then
   
10. ActiveSheet.Unprotect
    
11. 
    
12.     For i = 2 To 8
    
13.         aa = aa & Cells(i, 5).Value & ","
    
14.     Next
    
15.     aa = Left(aa, Len(aa) - 1)
    
16.     With Target.Validation
    
17.         .Delete
    
18.         .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
    
19.                 Operator:=xlBetween, Formula1:=aa
    
20.     End With
    
21.     ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
    
22.         , AllowFiltering:=True
    
23. ElseIf Target.Address = "$B$4" Then
    
24. ActiveSheet.Unprotect
    
25.     Set r1 = [e1:e11].Find([b3].Value)
    
26.     For i = r1.Row + 2 To 10
    
27.         aa = aa & Cells(i, 5).Value & ","
    
28.     Next
    
29.     aa = Left(aa, Len(aa) - 1)
    
30.     With Target.Validation
    
31.         .Delete
    
32.         .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
    
33.                 Operator:=xlBetween, Formula1:=aa
    
34.     End With
    
35.     ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
    
36.         , AllowFiltering:=True
    
37. 
    
38. ElseIf Target.Address = "$B$7" Then
    
39. ActiveSheet.Unprotect
    
40.     aa = "是,否"
    
41.     With Target.Validation
    
42.         .Delete
    
43.         .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
    
44.                 Operator:=xlBetween, Formula1:=aa
    
45.     End With
    
46.     ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
    
47.         , AllowFiltering:=True
    
48. 
    
49. ElseIf Target.Address = "$B$8" Then
    
50. ActiveSheet.Unprotect
    
51.     aa = "否,"
    
52.     Set r1 = [e1:e11].Find([b3].Value)
    
53.     Set r2 = [e1:e11].Find([b4].Value)
    
54.     m = r2.Row - r1.Row
    
55.     For i = 3 To m + 3
    
56.         aa = aa & Cells(i, 6).Value & ","
    
57.     Next
    
58.     aa = Left(aa, Len(aa) - 1)
    
59.     With Target.Validation
    
60.         .Delete
    
61.         .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
    
62.                 Operator:=xlBetween, Formula1:=aa
    
63.     End With
    
64.     ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
    
65.         , AllowFiltering:=True
    
66. 
    
67. End If
    
68. End Sub

复制代码

蓝桥玄霜

Application.CommandBars(3).Controls("粘贴(&P)")就是菜单下面standard工具栏中的粘贴按钮。

蓝桥玄霜

请见附图中最后一个按钮。

蓝桥玄霜

请见附件。

piny

以29樓測試 問題如下

在result活頁中，有時候仍需查找其他活頁資訊，可否允許可以點選其他活頁資訊？

蓝桥玄霜

什么是“可以點選其他活頁資訊”？
是指还有需要在result表中筛选其它工作表的数据吗？