20170405xlVBA快速录入

Posted 2020-09-27 Excel VBA 小天地

Dim Rng As Range
Dim Arr As Variant
Dim LastCell As Range
Dim FindText As String
Dim ItemCount As Long
Dim Dic As Object
Private Sub CbOption_Change()
    FindText = CbOption.Text
    If Len(FindText) > 0 Then
        If Dic.Exists(FindText) = False Then
            Call FilterItems
        End If
    End If
End Sub
Private Sub CbOption_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    Application.EnableEvents = False
    If KeyCode = 13 Then
        LastCell.Value = CbOption.Text
    End If
    Application.EnableEvents = True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Application.EnableEvents = False
    If Target.Column = 5 Then
        If Target.Rows.Count = 1 Then
            Set LastCell = Target
            Me.CbOption.Visible = True
            Me.CbOption.Left = Target.Left
            Me.CbOption.Top = Target.Top
            Me.CbOption.Width = Target.Width * 1.5
            Me.CbOption.Height = Target.Height * 1.5
            Me.CbOption.Text = ""
            Call AddItems
        End If
    Else
        Me.CbOption.Clear
        Me.CbOption.Visible = False
    End If
    Application.EnableEvents = True
End Sub
Private Sub AddItems()
    Me.CbOption.Clear
    Set Dic = CreateObject("Scripting.Dictionary")
    Set Rng = Application.ThisWorkbook.Worksheets("选项").Range("A1:A117")
    Arr = Rng.Value
    For i = LBound(Arr) To UBound(Arr)
        Key = CStr(Arr(i, 1))
        Dic(Key) = ""
        Me.CbOption.AddItem Key
    Next i
End Sub
Private Sub FilterItems()
    ItemCount = Me.CbOption.ListCount - 1
    Set Rng = Application.ThisWorkbook.Worksheets("选项").Range("A1:A117")
    Arr = Rng.Value
    For i = LBound(Arr) To UBound(Arr)
        Key = CStr(Arr(i, 1))
        If Key Like "*" & FindText & "*" Then
            Me.CbOption.AddItem Key
        End If
    Next i
    For i = ItemCount To 0 Step -1
        Me.CbOption.RemoveItem (i)
    Next i
End Sub