office交流网--QQ交流群号

Access培训群:792054000         Excel免费交流群群:686050929          Outlook交流群:221378704    

Word交流群:218156588             PPT交流群:324131555

Excel VBA右键设置单元格有效性下拉框

2020-05-01 08:00:00
gufengaoyue
转贴
742
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean) '
On Error Resume Next '忽略错误
Application.ScreenUpdating = False '关闭屏幕刷新
If Target.Column = 2 And Target.Count = 1 Then '判断是否在B列右击鼠标
Application.CommandBars("CELL").Enabled = False '如果是,关闭鼠标右击弹出菜单
md = Join(Application.Transpose(Sheets("数据").Range("D6:D1000")), ",")
With Selection.Validation '对所单击的单元格,创建数据有效性
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=md  '"Hello,Very good,Every day,898,0044,44944"
.IgnoreBlank = True '设置单元格 允许空值
.InCellDropdown = True '提供下拉列标
.InputTitle = "友情提示" '提示标题
.ErrorTitle = "" '出错提示,可以自己添加
.InputMessage = "你在此单元格,可以选择一个费用类别。也可以自己添加实际发生的新类别。但必须是符合规定的类别。" '提示语句
.ErrorMessage = "" '出现非有效性中内容时的提示。可以自己添加
.IMEMode = xlIMEModeOff '关闭输入法
.ShowInput = True '如果用户输入了无效数据,显示数据有效性检查输入消息
.Show
Error = False '如果用户输入了无效数据,显示错误消息,
End With
Else '判断不在B列右击鼠标,则打开鼠标右击弹出菜单
Application.CommandBars("CELL").Enabled = True
End If '结束判断
Application.ScreenUpdating = True '恢复屏幕刷新
End Sub '结束过程
分享