Option Explicit
'=================================================================================================
'=============== ADJUST THE CODE IN THIS PART: ===================================
Private shN As String
'where the cursor go after leaving the combobox
' ofs1 As Long = 1 means 1 row below
' ofs2 As Long = 1 means 1 column to the right
Private Const ofs1 As Long = 0
Private Const ofs2 As Long = 1
' NOTE: you might adjust combobox property in Sub toShowCombobox()
'-------- Do not change this part --------------
Private rCell As Range
Private sCOL As Long
Private vList
Private nFlag As Boolean
Private d As Object
Private xRange As Range
Private oldVal As String
'named range: XDAV_
Private Sub ComboBox1_LostFocus()
If ComboBox1.Visible = True Then ComboBox1.Visible = False
vList = Empty
Application.OnKey xdvKey
End Sub
Sub toShowCombobox()
Dim Target As Range
'make sure the focus is still on this sheet
If ActiveWorkbook Is ThisWorkbook And ActiveSheet.Name = shN Then
Set Target = ActiveCell
'setting up combobox property, change to suit
With ComboBox1
.Height = Target.Height + 5
.Width = Target.Width + 10
.Top = Target.Top - 2
.Left = Target.Offset(0, 1).Left
.Visible = True
.Value = ""
.Activate
End With
Else
Application.OnKey xdvKey
End If
End Sub
'=================================================================================================
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Cells.CountLarge > 1 Then Exit Sub
If isValid(Target) Then 'if activecell has data validation type 3
shN = ActiveSheet.Name
Set xRange = Evaluate(Target.Validation.Formula1)
Application.OnKey xdvKey, ThisWorkbook.ActiveSheet.CodeName & ".toShowCombobox"
End If
End Sub
Function isValid(f As Range) As Boolean
Dim v
On Error Resume Next
v = f.Validation.Type
On Error GoTo 0
isValid = v = 3
End Function
Private Sub ComboBox1_GotFocus()
Dim dar As Object, x
If xRange Is Nothing Then ActiveCell.Activate: Exit Sub
With ComboBox1
.MatchEntry = fmMatchEntryNone
.Value = ""
vList = xRange.Value
Set dar = CreateObject("System.Collections.ArrayList") 'note: arraylist always case sensitive
Set d = CreateObject("scripting.dictionary"): d.CompareMode = vbTextCompare
For Each x In vList
d(CStr(x)) = Empty
Next
If d.Exists("") Then d.Remove ""
For Each x In d.keys
dar.Add x
Next
dar.Sort
'vList becomes unique, sorted & has no blank
vList = dar.Toarray()
.List = vList
.DropDown
dar.Clear: d.RemoveAll
End With
End Sub
Private Sub ComboBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
nFlag = False
With ComboBox1
Select Case KeyCode
Case 13 'Enter
If IsError(Application.Match(.Value, vList, 0)) Then
If .Value = "" Then
Application.EnableEvents = False
ActiveCell = ""
Application.EnableEvents = True
ActiveCell.Offset(ofs1, ofs2).Activate
Else
MsgBox "Wrong input", vbCritical
End If
Else
ActiveCell.Offset(ofs1, ofs2).Activate
End If
Case 27, 9 'esc 'tab
ActiveCell.Offset(ofs1, ofs2).Activate
Case vbKeyDown, vbKeyUp
nFlag = True 'don't change the list when combobox1 value is changed by DOWN ARROW or UP ARROW key
End Select
End With
End Sub
Private Sub ComboBox1_Change()
With ComboBox1
If IsNumeric(Application.Match(.Value, vList, 0)) Then
Application.EnableEvents = False
ActiveCell = .Value
Application.EnableEvents = True
End If
If nFlag = True Then Exit Sub
If Trim(.Value) = oldVal Then Exit Sub
If .Value <> "" Then
Call get_filterX
.List = d.keys
d.RemoveAll
.DropDown
Else 'if combobox1 is empty then get the whole list
On Error Resume Next
.List = vList
On Error GoTo 0
End If
oldVal = Trim(.Value)
End With
End Sub
Sub get_filterX()
'search without keyword order
Dim i As Long, x, z, q
Dim v As String
Dim flag As Boolean
d.RemoveAll
z = Split(UCase(ComboBox1.Value), " ")
For Each x In vList
flag = True: v = UCase(x)
For Each q In z
If InStr(1, v, q, vbBinaryCompare) = 0 Then flag = False: Exit For
Next
If flag = True Then d(x) = Empty
Next
End Sub
Sub get_filterY()
'search with keyword order
Dim x
Dim tx As String
d.RemoveAll
tx = UCase("*" & Replace((ComboBox1.Value), " ", "*") & "*")
For Each x In vList
If UCase(x) Like tx Then d(x) = Empty
Next
End Sub
Sub toEnable()
Application.EnableEvents = True
End Sub
Private Sub Worksheet_Deactivate()
Application.OnKey xdvKey
End Sub
