ComboBox does not disappear after selection

[claustro]

Hi all ,
My first message here
I am struggling to make the combo box I am using for selecting employees in my timetable disappear after selection.
It disappears only after clicking on another cell.
Is it possible to make it disapear after the click in the dropdown menu?

Another problem is if I click on the line between 2 cells the cursor makes a jump up or down , so you have to carefully select the cell .

I am a total beginner and I copied the vba code from a tutorial so I am unable to understand how I could fix the code
I tried to use the mini sheet feature but if I try to copy my sheet I receive the error: 1004 run-time referred to Set cboTemp = ws.OLEObjects("TempCombo")

this is the code I am using

'==========================
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, _
  Cancel As Boolean)
Dim str As String
Dim cboTemp As OLEObject
Dim ws As Worksheet
Dim Tgt As Range
Set Tgt = Target.Cells(1, 1)
Set ws = ActiveSheet
On Error GoTo errHandler

If Tgt.Validation.Type = 3 Then
    Cancel = True
End If

Set cboTemp = ws.OLEObjects("TempCombo")
  On Error Resume Next
  With cboTemp
    .ListFillRange = ""
    .LinkedCell = ""
    .Visible = False
  End With
On Error GoTo errHandler

If Tgt.Validation.Type = 3 Then
    Application.EnableEvents = False
    str = Tgt.Validation.Formula1
    str = Right(str, Len(str) - 2)
    With cboTemp
      .Visible = True
      .Left = Tgt.Left
      .Top = Tgt.Top
      .Width = Target.Width + 5
      .Height = Target.Height + 4
      .ListFillRange = ws.Range(str).Address
      .LinkedCell = Tgt.Address
    End With
    cboTemp.Activate
    'open the drop down list automatically
    Me.TempCombo.DropDown
  End If
 
errHandler:
  Application.EnableEvents = True
  Exit Sub

End Sub
'=========================================
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim str As String
Dim cboTemp As OLEObject
Dim ws As Worksheet
Set ws = ActiveSheet

Set cboTemp = ws.OLEObjects("TempCombo")
  On Error Resume Next
If cboTemp.Visible = True Then
  With cboTemp
    .Top = 10
    .Left = 10
    .ListFillRange = ""
    .LinkedCell = ""
    .Visible = False
    .Value = ""
  End With
End If

errHandler:
  Application.EnableEvents = True
  Exit Sub

End Sub
'====================================
'Optional code to move to next cell if Tab or Enter are pressed
'from code by Ted Lanham
'***NOTE: if KeyDown causes problems, change to KeyUp
'Table with numbers for other keys such as Right Arrow (39)
'https://msdn.microsoft.com/en-us/library/aa243025%28v=vs.60%29.aspx

Private Sub TempCombo_KeyDown(ByVal _
        KeyCode As MSForms.ReturnInteger, _
        ByVal Shift As Integer)
    Select Case KeyCode
        Case 9 'Tab
            ActiveCell.Offset(0, 1).Activate
        Case 13 'Enter
            ActiveCell.Offset(1, 0).Activate
        Case Else
            'do nothing
    End Select
End Sub
'====================================

 

[claustro]

The result I have achieved with your help and your add-in is awesome, but the file will be used by almost 5 persons the majority of whom are totally uncustomized to using a pc.
So if I could create a simple shareable file maybe it will be easier for me.
I started downloading xCOMBOBOX+DAVAL-dict+arraylist,ON-OFF,automatic 1.xlsm just for testing it but I receive an error as soon as I click on the cell.

run-time error '-2146232576 (80131700)':
automation error

debug report to this part
Set dar = CreateObject("System.Collections.ArrayList") 'note: arraylist always case sensitive

I checked the file on google Sheets online and it works flawlessly so probably I am having a problem with the setup of my excel copy setup.
Do you have any idea where I could start?

 

[claustro]

Another question just in case I am going to use the add-in version. Is it possible to make F8 , nonconsecutive insertione default ?

 

[Akuini]

1. Don't use the automatic version because it will reopen the combobox after you close it. Use the double-click version instead.
2. The code uses ArrayList object to sort the list. To use ArrayList, you need Net Framework 3.5 version installed on your Windows (even if you have a later version). But since your data is already sorted then you don't need that part. So I amended the code to remove the arraylist and you don't need to install Net Framework 3.5.

The file:

Orario V24.1 - double click

MediaFire is a simple to use free service that lets you put all your photos, documents, music, and video in a single place so you can access them anywhere and share them everywhere.

www.mediafire.com

Another question just in case I am going to use the add-in version. Is it possible to make F8 , nonconsecutive insertione default ?

Open vba window
Open VBAProject Search_deList_v2.1.xlam
Open Thisworkbook code module
In "Private Sub Workbook_Open()" uncomment this line: 'pF8flag = True 'toggle continuous mode, false = continuous, true = non-continuous

Private Sub Workbook_Open()
    
'sortFlag = True 'toggle sort order, true = ascending, false = original

'txb_SearchMode = 1

pF8flag = True 'toggle continuous mode, false = continuous, true = non-continuous


     Call xDAV_1.Search_deList

End Sub

 

[claustro]

Thank you very much for your help .
Probably I am going to use the add-in version because after the "fix" of making not consecutive insertion default works like a charm and it could be useful in the future if the number of employees will b higher so the search function could be useful

I am still having a problem with the other version of combo box.
I can insert the value only by clicking on it and then pressing enter. Is it possible to join the action "click and then enter " by only clicking?
I adjusted the position of the cell so it pops up on the same cell where the value will be inserted as shown below, is this the right way to do it?
.Left = Target.Offset(0, 0).Left

 

[Akuini]

I am still having a problem with the other version of combo box.
I can insert the value only by clicking on it and then pressing enter. Is it possible to join the action "click and then enter " by only clicking?
I adjusted the position of the cell so it pops up on the same cell where the value will be inserted as shown below, is this the right way to do it?
.Left = Target.Offset(0, 0).Left

Try replacing all code in the sheet with this one:

Option Explicit
'=================================================================================================
'=============== ADJUST THE CODE IN THIS PART: ===================================

'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 vList
Private nFlag As Boolean
Private xFlag As Boolean
Private d As Object
Private oldVal As String

Private Sub CommandButton1_Click()
xFlag = Not xFlag
    If xFlag = False Then
        If ComboBox1.Visible = True Then ComboBox1.Visible = False
    End If
        ActiveCell.Offset(ofs1, ofs2).Activate
        Application.EnableEvents = True
End Sub


Private Sub ComboBox1_Click()
If nFlag = False Then
        Call sentValue
End If
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If ComboBox1.Visible = True Then ComboBox1.Visible = False

If Target.Cells.CountLarge = 1 And xFlag = False Then
    'if activecell has data validation type 3
    If isValid(Target) Then Call toShowCombobox: Cancel = True
End If

End Sub

'=================================================================================================

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If ComboBox1.Visible = True Then ComboBox1.Visible = False:  vList = Empty

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 x
    
    With ComboBox1
        .MatchEntry = fmMatchEntryNone
        .Value = ""
            
            Set d = CreateObject("scripting.dictionary"): d.CompareMode = vbTextCompare
           
            vList = Evaluate(ActiveCell.Validation.Formula1)
            If IsError(vList) Then GoTo skip
            For Each x In vList
                d(CStr(x)) = Empty
            Next
            If d.Exists("") Then d.Remove ""
            If d.Count > 0 Then
               .List = d.keys
               .DropDown
               d.RemoveAll
            End If
    End With

Exit Sub
skip:
MsgBox "Incorrect data validation formula", vbCritical
ActiveCell.Offset(, 1).Activate
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
               Call sentValue
        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

Sub sentValue()
        Application.EnableEvents = False
        ActiveCell = Me.ComboBox1.Value
        Application.EnableEvents = True
        ActiveCell.Offset(ofs1, ofs2).Activate
If ComboBox1.Visible = True Then ComboBox1.Visible = False:  vList = Empty
End Sub

Sub toShowCombobox()

Dim Target As Range

Set Target = ActiveCell

        With ComboBox1
            .Height = Target.Height + 5
            .Width = Target.Width + 10
            .Top = Target.Top - 2
            .Left = Target.Offset(0, 0).Left
            .Visible = True
            .Activate
        End With

End Sub


Private Sub ComboBox1_Change()

With ComboBox1
    
    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
                    
                    If Not IsEmpty(vList) Then .List = vList
                    
            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

 

[claustro]

Y O U A R E A G E N I U S !!!

It works perfectly! Now we have 2 options to choose from. I never thought I would have achieved such a result after starting this project 15 days ago
Thank you very much for taking so much time in helping me!

 

[Akuini]

You're welcome, glad to help & thanks for the feedback.

 

[Akuini]

@claustro
Sorry, there's a bug in the code which is the code allows you to sent value that's not on the list, it shouldn't.
So, please replace Private Sub ComboBox1_GotFocus() with this one:

Private Sub ComboBox1_GotFocus()
Dim x
    
    With ComboBox1
        .MatchEntry = fmMatchEntryNone
        .Value = ""
            
            Set d = CreateObject("scripting.dictionary"): d.CompareMode = vbTextCompare
           
            vList = Evaluate(ActiveCell.Validation.Formula1)
            If IsError(vList) Then GoTo skip
            For Each x In vList
                d(CStr(x)) = Empty
            Next
            If d.Exists("") Then d.Remove ""
            If d.Count > 0 Then
               .List = d.keys
               vList = d.keys
               .DropDown
               d.RemoveAll
            End If
    End With

Exit Sub
skip:
MsgBox "Incorrect data validation formula", vbCritical
ActiveCell.Offset(, 1).Activate
End Sub

and replace Sub sentValue() with this one:

Sub sentValue()
    With Me.ComboBox1
        If .ListIndex > -1 Then
                Application.EnableEvents = False
                ActiveCell = .Value
                Application.EnableEvents = True
                ActiveCell.Offset(ofs1, ofs2).Activate
            If .Visible = True Then .Visible = False:  vList = Empty
        Else
                MsgBox "Wrong input", vbCritical
        End If
    End With
                
End Sub

 

[claustro]

Thank you very much !

 

[Akuini]

You're welcome & good luck with the project.