|
删除你所有的模块及工作表的代码和控件,在SHEET1添加一个combobox控件,复制以下代码到SHEET1 CODE: Private Sub ComboBox1_Change()
Dim arr, i As Long, n As Long, s() As String
arr = Sheets("sheet2").[c5].Resize(Sheets("sheet2").[c65536].End(xlUp).Row - 4, 1)
If Len(ComboBox1.Text) = 0 Then
ComboBox1.List = arr
Exit Sub
End If
For i = 1 To UBound(arr)
If pinyin(arr(i, 1)) Like UCase(ComboBox1.Text) & "*" Then
n = n + 1
ReDim Preserve s(1 To n)
s(n) = arr(i, 1)
End If
Next
If n = 0 Then
ComboBox1.Interior.Color = vbRed
ComboBox1.Visible = False
Exit Sub
End If
ComboBox1.List = WorksheetFunction.Transpose(s)
ComboBox1.DropDown
If n = 1 Then ComboBox1.ListIndex = 0
End Sub Private Sub ComboBox1_Click()
ComboBox1.TopLeftCell = ComboBox1.Text
ComboBox1.Visible = False
End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.ScreenUpdating = False
Dim arr
arr = Sheets("sheet2").[c5].Resize(Sheets("sheet2").[c65536].End(xlUp).Row - 4, 1)
If Target.Cells.Count = 1 And Target.Column = 2 And Target.Row > 2 Then
With ComboBox1
.Visible = True
.Left = ActiveCell.Left
.Top = ActiveCell.Top
.Width = ActiveCell.Width
.Height = ActiveCell.Height
.Text = ""
End With
ComboBox1.Clear
ComboBox1.List = arr
ComboBox1.Activate
End If
Application.ScreenUpdating = True
End Sub Function pinyin(ByVal r As String) As String
Const hanzi = "啊芭擦搭蛾发噶哈击喀垃妈拿哦啪期然撒塌挖昔压匝ABCDEFGHJKLMNOPQRSTWXYZZ"
Dim i As Long, j As Byte, temp As String
For i = 1 To Len(r)
For j = 1 To 24
If Asc(Mid(r, i, 1)) >= Asc(Mid(hanzi, j, 1)) Then temp = Mid(hanzi, 23 + j, 1)
Next
pinyin = pinyin & temp
Next
End Function | 
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2007-5-26 20:05
