|
Sub bbb()
Application.EnableEvents = False
Selection.Value = Application.CommandBars.ActionControl.Caption 把选中值填如目标
Application.EnableEvents = True
End Sub Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
If Target.Row < 2 Then Exit Sub
If Target.Column > 1 Then Exit Sub 3种情况下退出
vl = Target.Value 取值
If Len(vl) > 1 Then Exit Sub 多于1个字退出
Target.Select 回到原单元格
On Error Resume Next
Set sj = Worksheets("Sheet2")
ed = sj.[a65536].End(xlUp).Row
Set rg = sj.Range("a2:a" & ed).Find(vl, LookIn:=xlValues) 找第一个匹配值
If rg Is Nothing Then Exit Sub 没有就退出
With Application.CommandBars.Add(Name:="mycell", Position:=msoBarPopup) 设置菜单
r0 = 1 已查到行
r = rg.Row 新查到行
Do While r > r0 新查到比已查到大就继续
r0 = r
With .Controls.Add(Type:=msoControlButton) 设置菜单项
.Caption = rg.Value 把查到值作为显示值
.OnAction = "bbb" 如选择此项运行bbb
End With
Set rg = sj.Range("a2:a" & ed).FindNext(rg) 找下一个
If Not rg Is Nothing Then r = rg.Row 如果找到了取新查到行值
Loop
End With
If Application.CommandBars("Mycell").Controls.Count = 1 Then 如果仅查到1项
Application.EnableEvents = False
Selection.Value = Application.CommandBars("Mycell").Controls(1).Caption 把值直接填入目标
Application.EnableEvents = True
Else
Application.CommandBars("Mycell").ShowPopup 否则弹出菜单
End If
Application.CommandBars("Mycell").Delete 删除菜单
End Sub
| 
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2008-8-31 10:27
楼主
