(Excel VBA) How to Show AutoComplete Feature of a ComboBox as a DropDown List - vba

I would like the following code to add values to a combobox, then when the user inputs characters into the combobox, the dropdown feature of the combobox will show only those items which contain those characters, similarly to the way the Google Search Bar works.
(source: intersites.com)
Code Edit:
Option Explicit
Option Compare Text
Public LC As Long
Public Count As Integer
Dim ComboArray() As String
'Initializes the userform, and saves values from database into an array
Private Sub UserForm_Initialize()
LC = Cells(1, Columns.Count).End(xlToLeft).Column
ReDim ComboArray(1 To LC)
For Count = 1 To LC
ComboArray(Count) = Cells(1, Count).Value
Next Count
End Sub
'Prevents changes if the down key is pressed?
Private Sub ComboBox_SiteName_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Application.ScreenUpdating = False
End Sub
'Adds values to combobox if they contain the string input by user
Private Sub ComboBox1_Change()
Dim pos As Integer
Dim i As Integer
ComboBox1.Clear
For Count = 1 To LC
pos = InStr(1, ComboArray(Count), ComboBox1.Value)
If pos <> 0 Then
With ComboBox1
.AddItem Cells(1, Count)
End With
End If
Next Count
End Sub

Here is a simple example, which may need refinement for your purposes, but illustrates the general principles of using the KeyPress event to build a string of user input, and compare that to each item in the list, effectively filtering the list to values that start with the input string.
This needs some refinement to handle backspacing, deleting, etc., which I tried to do, but didn't get as far as I'd like.
Code:
Option Explicit
Dim cbList As Variant
Dim userInput$
'### USERFORM EVENTS
Private Sub ComboBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Select Case KeyCode
Case 8, 48
'MsgBox "Backspace"
Debug.Print "Backspace"
If userInput <> "" Then
userInput = Left(userInput, Len(userInput) - 1)
End If
Case 46
'MsgBox "Delete"
Debug.Print "Delete"
userInput = Replace(userInput, ComboBox1.SelText, "")
End Select
End Sub
Private Sub UserForm_Activate()
Dim cl As Range
userInput = ""
For Each cl In Range("A1:A8")
Me.ComboBox1.AddItem cl.Value
Next
Me.ComboBox1.MatchRequired = False
cbList = Me.ComboBox1.List
End Sub
Private Sub UserForm_Terminate()
userInput = ""
End Sub
'#### END USERFORM EVENTS
'#### COMBOBOX EVENTS
Private Sub ComboBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
Me.ComboBox1.List = cbList
' Capture the user input in module variable
userInput = userInput & Chr(KeyAscii)
Debug.Print "input: " & userInput
Debug.Print KeyAscii
Dim i As Long, itm
For i = Me.ComboBox1.ListCount - 1 To 0 Step -1
itm = Me.ComboBox1.List(i)
If Not StartsWith(CStr(itm), userInput) Then
Me.ComboBox1.RemoveItem i
End If
Next
If Me.ComboBox1.ListCount = 0 Then
Me.ComboBox1.List = cbList
Else
Me.ComboBox1.List = Me.ComboBox1.List
End If
Me.ComboBox1.DropDown
End Sub
'#### END COMBOBOX EVENTS
'#### HELPER FUNCTIONS
Function StartsWith(imtVal$, inputStr$, Optional caseSensitive As Boolean = False)
', Optional caseSensitive As Boolean = False
'If Not caseSensitive Then
imtVal = LCase(imtVal)
inputStr = LCase(inputStr)
'End If
StartsWith = VBA.Strings.Left(imtVal, Len(inputStr)) = inputStr
End Function
'#### END HELPER FUNCTIONS

Related

Passing an user form result to vba code variable

I have a code that counts the files in a folder if they contain a specific string on their name.
For example: If I want it to count the files with close on their name (Close_26_03_2003.csv).
Currently the code reads the value of a cell in the sheet and searches for that string in the file name with the (InStr function). Problem is I have to write the type of file in the cell.
What I am trying to do is create an user form, with three option buttons (open, close and cancel). For open it sets the string equal to open, and search for files that have it on their name (same as for close). Cancel ends the sub.
Problem is I don't know which code I have to use in the user form for this and don't know how to pass it to the code that counts files (I though about assigning it to a variable).
Code as is:
Sub CountFiles3()
Dim path As String, count As Integer, i As Long, var As Integer
Dim ws As Worksheet
Dim Filename As String
Dim FileTypeUserForm As UserForm1
Application.Calculation = xlCalculationManual
path = ThisWorkbook.path & "\*.*"
Filename = Dir(path)
'the problem is here:
'x = user form result***************
'if cancel = true, end sub
Set ws = ThisWorkbook.Sheets("FILES")
i = 0
Do While Filename <> ""
'var = InStr(Filename, ws.Cells(2, 7).Value) 'this is current code, it checks if the cell has open or close
var = InStr(Filename, x)
If var <> 0 Then
i = i + 1
ws.Cells(i + 1, 1) = Filename
Filename = Dir()
Else: Filename = Dir()
End If
Loop
Application.Calculation = xlCalculationAutomatic
ws.Cells(1, 2) = i
MsgBox i & " : files found in folder"
End Sub
And this is my current user form code:
Private Sub Cancel_Click()
Me.Tag = 3 ' EndProcess
Me.Hide
End Sub
Private Sub ClosingType_Click()
Me.Tag = 2 ' "CLOSING"
Me.Hide
End Sub
Private Sub OpeningType_Click()
Me.Tag = 1 ' "OPENING"
Me.Hide
End Sub
Any ideas?
add following code to your CountFiles3() sub in the "'the problem is here:" section:
Dim x As String
x = GetValue
If x = "end" Then Exit Sub
then add following code in any module:
Function GetValue()
With MyUserForm '<--| change "MyUserForm " to your actual UserForm name
.Show
GetValue = .Tag
End With
Unload MyUserForm '<--| change "MyUserForm " to your actual UserForm name
End Function
and change your Userform code as follwos
Private Sub Cancel_Click()
Me.Tag = "end" ' EndProcess
Me.Hide
End Sub
Private Sub ClosingType_Click()
Me.Tag = "close" ' "CLOSING"
Me.Hide
End Sub
Private Sub OpeningType_Click()
Me.Tag = "open" ' "OPENING"
Me.Hide
End Sub

Setting validation for combo box error

#
updated codes
Function condition(ByRef objCmb As ComboBox)
If objCmb.Value ="" And objCmb.Value = "g" Then
Call MsgBox("gg", vbOKOnly, "error")
End If
End Function
Private Sub ComboBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
condition (ComboBox1)
End Sub
'other codes for reference:
Private Sub CommandButton1_Click()
Dim lastrow As Integer
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To 3
For j = 1 To 5
With Me.Controls("ComboBox" & (i - 1) * 5 + j)
If .Text <> "" Then
Cells(lastrow + i, j) = .Text
Else
Exit Sub
End If
End With
Next j
Next i
End Sub
I have 50 combo and text boxes in VBA user panel. As it is too troublesome to set constraints in every combo or text box, I want a function to apply to every combo and text box.
For the codes above , it shows up cant find objecterror
How to solve ?
Btw , how to set the function statement for textbox ?
is it Function condition2(ByRef objCmb As textbox)...
You are receiving an error because ComboBox is not ByRef objCmb As ComboBox. Don't use parenthesis when calling a sub. Don't use parenthesis when calling function if you are not using the functions return value. If a function does not return a value it should be a sub.
Sub condition(ByRef objCmb As MSForms.ComboBox)
If objCmb.Value <> "" And objCmb.Value = "g" Then
MsgBox "gg", vbOKOnly, "error"
objCmb.Value = ""
End If
End Sub
Private Sub ComboBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
condition ComboBox1
End Sub
I wrote a function to help you generate the Exit event code for all your text and combo boxes.
Sub AddCodeToCipBoard(frm As UserForm)
Const BaseCode = " Private Sub #Ctrl_Exit(ByVal Cancel As MSForms.ReturnBoolean)" & vbCrLf & _
" condition ComboBox1" & vbCrLf & _
" End Sub" & vbCrLf & vbCrLf
Dim s As String
Dim ctrl
Dim clip As DataObject
Set clip = New DataObject
For Each ctrl In frm.Controls
If TypeName(ctrl) = "ComboBox" Or TypeName(ctrl) = "TextBox" Then
s = s & Replace(BaseCode, "#Ctrl", ctrl.Name)
End If
Next
clip.SetText s
clip.PutInClipboard
End Sub
Put this code in a module and call it like this:
AddCodeToCipBoard Userform1
Now all the Exit event code will be copied into the Windows Clipboard. Go into your Userforms code module and paste the new code.
Example Output:
Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
condition ComboBox1
End Sub
Private Sub TextBox2_Exit(ByVal Cancel As MSForms.ReturnBoolean)
condition ComboBox1
End Sub
Private Sub TextBox3_Exit(ByVal Cancel As MSForms.ReturnBoolean)
condition ComboBox1
End Sub
Private Sub ComboBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
condition ComboBox1
End Sub
Private Sub TextBox4_Exit(ByVal Cancel As MSForms.ReturnBoolean)
condition ComboBox1
End Sub

Excel: Selecting single cell vs. whole column in VBA

This is a newb question:
I have two sheets. Sheet 1 is where there is a form to enter data. When you double click on any cell in column A, a user form pop up comes up. You enter a few keys from any entry that is in the A column of sheet 2 and it autocompletes.
The problem I am having is: I only want to enter data on a specific cell, for instance A1 .. not the whole column of A. A second thing I wanted was that instead of a double click, I wanted it to work with a single click. Can anyone please help.
Here is the VBA code for Sheet 1 where you enter the data
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim uiChosen As String
Dim MyList As Range
Dim myPrompt As String
If Target.Column <> 1 Then Exit Sub
Set MyList = Sheet2.Range("Cariler")
myPrompt = "Lütfen Bir Cari Seçin"
uiChosen = UserForm1.ChooseFromList(MyList, myPrompt, Default:=Target.Value, xlFilterStyle:=xlContains)
If StrPtr(uiChosen) <> 0 Then
Target.Value = uiChosen
Cancel = True
End If
End Sub
Here is the code for the user form:
Option Explicit
' in userform's code module
Dim FullList As Variant
Dim FilterStyle As XlContainsOperator
Dim DisableMyEvents As Boolean
Dim AbortOne As Boolean
Const xlNoFilter As Long = xlNone
Private Sub butCancel_Click()
Unload Me
End Sub
Private Sub butOK_Click()
Me.Tag = "OK"
Me.Hide
End Sub
Private Sub ComboBox1_Change()
Dim oneItem As Variant
Dim FilteredItems() As String
Dim NotFlag As Boolean
Dim Pointer As Long, i As Long
If DisableMyEvents Then Exit Sub
If AbortOne Then AbortOne = False: Exit Sub
If TypeName(FullList) Like "*()" Then
ReDim FilteredItems(1 To UBound(FullList))
DisableMyEvents = True
Pointer = 0
With Me.ComboBox1
Select Case FilterStyle
Case xlBeginsWith: .Tag = LCase(.Text) & "*"
Case xlContains: .Tag = "*" & LCase(.Text) & "*"
Case xlDoesNotContain: .Tag = "*" & LCase(.Text) & "*": NotFlag = True
Case xlEndsWith: .Tag = "*" & LCase(.Text)
Case xlNoFilter: .Tag = "*"
End Select
For Each oneItem In FullList
If (LCase(oneItem) Like .Tag) Xor NotFlag Then
Pointer = Pointer + 1
FilteredItems(Pointer) = oneItem
End If
Next oneItem
.List = FilteredItems
.DropDown
DisableMyEvents = False
If Pointer = 1 Then .ListIndex = 0
End With
End If
End Sub
Private Sub ComboBox1_Click()
butOK.SetFocus
End Sub
Private Sub ComboBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Select Case KeyCode
Case vbKeyReturn: Call butOK_Click
Case vbKeyUp, vbKeyDown: AbortOne = True
End Select
End Sub
Private Sub Label1_Click()
End Sub
Private Sub UserForm_Activate()
ComboBox1.SetFocus
If ComboBox1.Text <> vbNullString Then
Call ComboBox1_Change
End If
End Sub
Private Sub UserForm_Initialize()
ComboBox1.MatchEntry = fmMatchEntryNone
End Sub
Public Function ChooseFromList(ListSource As Variant, Optional Prompt As String = "Choose one item", _
Optional Title As String = "Cari Arama Programı", Optional Default As String, _
Optional xlFilterStyle As XlContainsOperator = xlBeginsWith) As String
Dim Pointer As Long, oneItem As Variant
If TypeName(ListSource) = "Range" Then
With ListSource
Set ListSource = Application.Intersect(.Cells, .Parent.UsedRange)
End With
If ListSource Is Nothing Then Exit Function
If ListSource.Cells.Count = 1 Then
ReDim FullList(1 To 1): FullList(1) = ListSource.Value
ElseIf ListSource.Rows.Count = 1 Then
FullList = Application.Transpose(Application.Transpose(ListSource))
Else
FullList = Application.Transpose(ListSource)
End If
ElseIf TypeName(ListSource) Like "*()" Then
ReDim FullList(1 To 1)
For Each oneItem In ListSource
Pointer = Pointer + 1
If UBound(FullList) < Pointer Then ReDim Preserve FullList(1 To 2 * Pointer)
FullList(Pointer) = oneItem
Next oneItem
ReDim Preserve FullList(1 To Pointer)
ElseIf Not IsObject(ListSource) Then
ReDim FullList(1 To 1)
FullList(1) = CStr(ListSource)
Else
Err.Raise 1004
End If
Me.Caption = Title
Label1.Caption = Prompt
FilterStyle = xlFilterStyle
DisableMyEvents = True
ComboBox1.Text = Default
ComboBox1.List = FullList
DisableMyEvents = False
butOK.SetFocus
Me.Show
With UserForm1
If .Tag = "OK" Then ChooseFromList = .ComboBox1.Text
End With
End Function
There is no single click event. Use Intersect to test wherther or not the target cell is within a given range.
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Target, Range("A1")) Is Nothing Then
Dim uiChosen As String
Dim MyList As Range
Dim myPrompt As String
If Target.Column <> 1 Then Exit Sub
Set MyList = Sheet2.Range("Cariler")
myPrompt = "Lütfen Bir Cari Seçin"
uiChosen = UserForm1.ChooseFromList(MyList, myPrompt, Default:=Target.Value, xlFilterStyle:=xlContains)
If StrPtr(uiChosen) <> 0 Then
Target.Value = uiChosen
Cancel = True
End If
End If
End Sub

Incorporating refedit into Vlookup userform

I have a vlookup userform which autofills the details in the form based on the seat n°.
Now I want to incoroporate a ref edit to paste these data from the text box to the cells the user chooses with the refedit. Hence i would need some help in going about these. This is the code i have used. I potentially want to insert 3 refedit boxes for user to select the cell they want to paste each of the data (Name,Dept and Ext No.) from the textbox.
See my code below:
Option Explicit
Private Sub Frame1_Click()
End Sub
Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
Dim answer As Integer
answer = TextBox1.Value
TextBox2.Value = WorksheetFunction.VLookup(answer, Sheets("L12 - Data Sheet").Range("B:E"), 2, False)
TextBox3.Value = WorksheetFunction.VLookup(answer, Sheets("L12 - Data Sheet").Range("B:E"), 3, False)
TextBox4.Value = WorksheetFunction.VLookup(answer, Sheets("L12 - Data Sheet").Range("B:E"), 4, False)
End Sub
Private Sub TextBox2_Change()
End Sub
Private Sub TextBox3_Change()
End Sub
Private Sub TextBox4_Change()
End Sub
Private Sub CancelButton_Click()
Unload Me
End
End Sub
I have tried figuring out a code to solve this issue but I am getting an object required error. My rngcopy would be textbox2.value (Name) and the rngpaste location would be the ref edit 1.
This is the code
Private Sub PasteButton_Click()
Dim rngCopy As Range, rngPaste As Range
Dim wsPaste As Range
Dim answer As Integer
answer = TextBox1.Value
If RefEdit1.Value <> "" Then
TextBox2.Value = WorksheetFunction.VLookup(answer, Sheets("L12 - Data Sheet").Range("B:E"), 2, False)
Set rngCopy = TextBox2.Value
Set wsPaste = ThisWorkbook.Sheets(Replace(Split(TextBox2.Value, "!")(0), "'", ""))
Set rngPaste = wsPaste.Range(Split(TextBox2.Value, "!")(1))
rngCopy.Copy rngPaste
Else
MsgBox "Please select an Output range"
End If
End Sub
You should get the row index with Match and expose it to the form so it can be used by the copy function.
And to set the target pointed by a Ref control, just evalute the .Value property with Range():
Range(RefEdit.Value).cells(1, 1) = Worksheet.Cells(row, column)
The form:
The code:
' constants to define the data
Const SHEET_DATA = "L12 - Data Sheet"
Const COLUMN_SEAT = "B"
Const COLUMNN_NAME = "C"
Const COLUMN_DEPT = "D"
Const COLUMN_EXTNO = "E"
Private Sheet As Worksheet
Private RowIndex As Long
Private Sub TxtSeatNo_Change()
Dim seatno
'clear the fields first
Me.TxtName.value = Empty
Me.TxtDept.value = Empty
Me.TxtExtNo.value = Empty
RowIndex = 0
If Len(TxtSeatNo.value) Then
Set Sheet = ThisWorkbook.Sheets(SHEET_DATA)
On Error Resume Next
' get the seat number to either string or double
seatno = TxtSeatNo.value
seatno = CDbl(seatno)
' get the row index containing the SeatNo
RowIndex = WorksheetFunction.match(seatno, _
Sheet.Columns(COLUMN_SEAT), _
0)
On Error GoTo 0
End If
If RowIndex Then
' copy the values from the sheet to the text boxes
Me.TxtName.value = Sheet.Cells(RowIndex, COLUMNN_NAME)
Me.TxtDept.value = Sheet.Cells(RowIndex, COLUMN_DEPT)
Me.TxtExtNo.value = Sheet.Cells(RowIndex, COLUMN_EXTNO)
End If
End Sub
Private Sub BtCopy_Click()
If RowIndex < 1 Then Exit Sub
' copy the current values to the cells pointed by the ref controls
If Len(Me.RefName.value) Then _
Range(Me.RefName.value) = Sheet.Cells(RowIndex, COLUMNN_NAME)
If Len(Me.RefDept.value) Then _
Range(Me.RefDept.value) = Sheet.Cells(RowIndex, COLUMN_DEPT)
If Len(Me.RefExtNo.value) Then _
Range(Me.RefExtNo.value) = Sheet.Cells(RowIndex, COLUMN_EXTNO)
End Sub
Private Sub BtlClose_Click()
' close the form
Unload Me
End Sub
You are declaring your rngCopy as a Range Object and then later on you are binding it to a .value method of the range object.
Set rngCopy = TextBox2.Value
This is likely where you are encountering errors. Try declaring a string and assigning it to your copy value.
Dim string1 As String
string1 = TextBox2.Value
Step through your code editor with the LOCALS window open, and watch what happens to your rngCopy object when you assign a string to it.

How to display Values from a multiselect listbox

I have a form in Excel macro. This form will capture the values inserted in textboxes, listbox and store in Sheet2.
There are 2 buttons in the form applet named "Next" and "Previous". These button will be used for navigating between the saved records. I am able to navigate between records and the values display fine in textboxes. However, I am not sure how can I display the Values from listboxes. My list box is a multiselect list box.
I have provided snippet of my code on how the records are saved in sheet2 and how the navigation happens when clicked on Next button.
Private Sub Save_Click()
Dim ctl As Control
Dim S As String
Dim i As Integer
RowCount = Worksheets("Sheet2").Range("A1").CurrentRegion.Rows.Count
With Worksheets("Sheet2").Range("A1")
.Offset(RowCount, 0).Value = Me.Name1.Value ' capture value from list box
'below code is for capturing value from multiselect listbox
With AOI
For i = 0 To .ListCount - 1
If .Selected(i) = True Then S = S & ", " & .List(i)
Next i
Range("A1").Offset(RowCount, 10).Value = S
End With
End Sub
Below code is for navigating between saved records..
Private Sub Next1_Click()
strCurrentSetofRows = Worksheets("Sheet2").Range("A1").CurrentRegion.Rows.Count
i = i + 1: j = 0
If i > (strCurrentSetofRows - 1) Then
MsgBox "No More Records"
Exit Sub
End If
Set sRange = Worksheets("Sheet2").Range("A1")
Name1.Text = sRange.Offset(i, j).Value: j = j + 1
End Sub
Any thoughts on how can I display saved values of AOI (my field).
Since you are storing the values using , as a separator, you can use the same to split the values and upload it to the ListBox. BTW, I hope you are generating the ListBox with the complete list in the UserForm's Initialize event?
Here is a very basic example. Please amend it to suit your needs.
Let's say Cell A1 has Blah1,Blah2,Blah6. Then try this code
Option Explicit
Dim i As Long, j As Long
Private Sub UserForm_Initialize()
ListBox1.MultiSelect = fmMultiSelectMulti
For i = 1 To 10
ListBox1.AddItem "Blah" & i
Next
End Sub
Private Sub CommandButton1_Click()
Dim ArValues As Variant
Dim sValue As String
Dim multivalues As Boolean
If InStr(1, Range("A1").Value, ",") Then
ArValues = Split(Range("A1").Value, ",")
multivalues = True
Else
sValue = Range("A1").Value
multivalues = False
End If
If multivalues = True Then
For i = 0 To UBound(ArValues)
For j = 0 To ListBox1.ListCount - 1
If ListBox1.List(j) = ArValues(i) Then
ListBox1.Selected(j) = True
Exit For
End If
Next j
Next i
Else
For j = 0 To ListBox1.ListCount - 1
If ListBox1.List(j) = sValue Then
ListBox1.Selected(j) = True
Exit For
End If
Next j
End If
End Sub
Screenshot