I have to generate hundreds of form control dropdowns with same item values. So i would like to clone them if possible. And i should be able to change few attributes like Name, OnAction Any ideas would be appreciated greatly.
Sub Macro1()
Dim c As Range, i As Long, nm As String
Dim sht As Worksheet
Set sht = ActiveSheet
i = 0
For Each c In sht.Range("A2:A20")
i = i + 1
nm = "dd_" & i
On Error Resume Next
sht.Shapes(nm).Delete
On Error GoTo 0
With sht.DropDowns.Add(c.Left, c.Top, c.Width, c.Height)
.Name = nm
.ListFillRange = "K1:K6"
.LinkedCell = ""
.DropDownLines = 8
.Display3DShading = False
.OnAction = "HandleClick"
End With
Next c
End Sub
Handler:
Sub HandleClick()
Debug.Print Application.Caller
End Sub
Related
I have a workbook with 2 sheets (one to place the data and another for options).
The one with the data it has some buttons (at row 1), some textBox and DropBox (at row 2) and at row 3 are the headers of the table with all the data below.
The sheet with the options for the moment has only one button to recreate the menu (the TextBox and DropBox at row 2 in the data sheet)
However when pressing the button to run the macro it gives error 400 with no description and a red x signal. Sometimes it gives error when re-creating and first textBox, sometimes the second or third as well (never the fourth or the fifth).
Why does such 400 error happen ? What causing it ?
When trying debug the code i placed some Debug.Print in some places and after running 3 times (after clicking in button 3 times this is the output in the immediate window.
-----------Running createMenu-----------
TextBox5 DIM done
TextBox5 Set done
TextBox6 Delete
-----------Running createMenu-----------
TextBox5 Delete
TextBox5 DIM done
TextBox5 Set done
TextBox6 DIM done
TextBox6 Set done
TextBox7 Delete
-----------Running createMenu-----------
TextBox5 Delete
The code below (the one to recreate the menus) is placed in the data worksheet.
Sub createMenu()
Debug.Print "-----------Running createMenu-----------"
Dim wb As Workbook
Set wb = ThisWorkbook
Dim ws As Worksheet
Set ws = wb.Sheets("Dados1")
With ws
.Range("A2").NumberFormat = "0"
.Range("B2").NumberFormat = "dd-mm-yyyy"
.Range("C2:D2").Merge
.Range("C2:D2").NumberFormat = "hh:mm:ss"
Call newTextBox(.Range("E2"))
Application.Wait (Now + TimeValue("0:00:02"))
Call newTextBox(.Range("F2"))
Application.Wait (Now + TimeValue("0:00:02"))
Call newTextBox(.Range("G2"))
Application.Wait (Now + TimeValue("0:00:02"))
Call newTextBox(.Range("H2"))
Application.Wait (Now + TimeValue("0:00:02"))
Call newTextBox(.Range("I2"))
Call newDropBox(.Range("J2"), "=Opções!A1:A14")
Call newDropBox(.Range("K2"), "=Opções!B1:B2")
.Range("A2:N2").HorizontalAlignment = xlCenter
End With
End Sub
Sub newDropBox(t As Range, list As String)
Dim wb As Workbook
Set wb = ThisWorkbook
Dim ws As Worksheet
Set ws = wb.Sheets("Dados1")
With ws.Range(t.Address).Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=list
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
End Sub
Sub newTextBox(t As Range)
Dim wb As Workbook
Set wb = ThisWorkbook
Dim ws As Worksheet
Set ws = wb.Sheets("Dados1")
With ws
Dim OLEObj As OLEObjects
If .OLEObjects.Count > 0 Then
Dim x As Integer
For x = 1 To .OLEObjects.Count
If .OLEObjects(x).Name = "TextBox" & t.Column Then
.OLEObjects(x).Delete
Debug.Print "TextBox" & t.Column & " Delete"
End If
Next x
End If
Dim myTextBox As OLEObject
Debug.Print "TextBox" & t.Column; " DIM done"
Set myTextBox = .OLEObjects.Add("Forms.TextBox.1")
Debug.Print "TextBox" & t.Column; " Set done"
With myTextBox
.Name = "TextBox" & t.Column
.LinkedCell = t.Address
.Left = t.Cells.Left
.Top = t.Cells.Top
.Width = t.Cells.Width
.Height = t.Cells.Height
.Object.BackColor = 16777152
.Object.BorderStyle = 1
.Object.BorderColor = 0
End With
End With
End Sub
So i find out the reason ...
So when i am doing the for loop he started by finding (lets say 2 OLEObjects).
If the in the first cycle of the loop the wanted object is found he delete one of the objects making it the total OLEObjects count to less 1.
There for when cycling to the second OLEObjects he will not find it, and throw such 400 error.
So the fix i done was exit the loop when the target OLEObjects is found.
Sub newTextBox(t As Range)
Dim wb As Workbook
Set wb = ThisWorkbook
Dim ws As Worksheet
Set ws = wb.Sheets("Dados1")
With ws
Dim OLEObj As OLEObjects
If .OLEObjects.Count > 0 Then
Dim x As Integer
For x = 1 To .OLEObjects.Count
If .OLEObjects(x).Name = "TextBox" & t.Column Then
.OLEObjects(x).Delete
Exit For
End If
Next x
End If
Dim myTextBox As OLEObject
Set myTextBox = .OLEObjects.Add("Forms.TextBox.1")
With myTextBox
.Name = "TextBox" & t.Column
.LinkedCell = t.Address
.Left = t.Cells.Left
.Top = t.Cells.Top
.Width = t.Cells.Width
.Height = t.Cells.Height
.Object.BackColor = 16777152
.Object.BorderStyle = 1
.Object.BorderColor = 0
End With
End With
End Sub
enter image description hereI have a spreadsheet that has 3 checkbox options for each row, I have created a VBA to disable the other 2 checkboxes once a checkbox is created (so that only 1 checkbox can be checked), however my solution only works for one row and I need some help in rewriting this so that it will apply to all rows please. (I'm new to VBA).
The code I have used is this:
Private Sub CheckBox1_Click()
If CheckBox1.Value = True Then
CheckBox2.Value = False
CheckBox2.Enabled = False
CheckBox3.Value = False
CheckBox3.Enabled = False
Else
CheckBox2.Value = False
CheckBox2.Enabled = True
CheckBox3.Value = False
CheckBox3.Enabled = True
End If
End Sub
Private Sub CheckBox2_Click()
If CheckBox2.Value = True Then
CheckBox1.Value = False
CheckBox1.Enabled = False
CheckBox3.Value = False
CheckBox3.Enabled = False
Else
CheckBox1.Value = False
CheckBox1.Enabled = True
CheckBox3.Value = False
CheckBox3.Enabled = True
End If
End Sub
Private Sub CheckBox3_Click()
If CheckBox3.Value = True Then
CheckBox1.Value = False
CheckBox1.Enabled = False
CheckBox2.Value = False
CheckBox2.Enabled = False
Else
CheckBox1.Value = False
CheckBox1.Enabled = True
CheckBox2.Value = False
CheckBox2.Enabled = True
End If
End Sub
You should probably just use Radios it would be a lot simpler.
If you are intent on doing this you will need to delete all your boxes and then put this code in. It will create and name your boxes and assign them code on click.
Alright, This needs to go in your Sheet module:
Sub Worksheet_Activate()
'Change Module2 to whatever the module name you are using is.
Module2.ActivateCheckBoxes ActiveSheet
End Sub
This next stuff will go into the module you're referencing from the Worksheet Module.
Sub ActivateCheckBoxes(sht As Worksheet)
If sht.CheckBoxes.Count = 0 Then
CreateCheckBoxes sht
End If
Dim cb As CheckBox
For Each cb In sht.CheckBoxes
'You may be able to pass sht as an object, It was giving me grief though
cb.OnAction = "'Module2.CheckBoxClick """ & cb.name & """, """ & sht.name & """'"
Next cb
End Sub
Sub CreateCheckBoxes(sht As Worksheet)
Dim cell As Range
Dim chkbox As CheckBox
With sht
Dim i As Long
Dim prevrow As Long
prevrow = 0
For Each cell In .Range("B2:D5") 'Change this to whatever range you want.
If prevrow < cell.row Then
prevrow = cell.row
i = 0
End If
Set chkbox = .CheckBoxes.Add(cell.Left, cell.Top, 30, 6)
With chkbox
.name = "CheckBox" & i & "_" & cell.row
.Caption = ""
End With
i = i + 1
Next cell
End With
End Sub
Sub CheckBoxClick(chkname As String, sht As String)
Dim cb As CheckBox
With Worksheets(sht)
For Each cb In .CheckBoxes
If Split(cb.name, "_")(1) Like Split(chkname, "_")(1) And Not cb.name Like chkname Then
cb.Value = -4146
End If
Next cb
End With
End Sub
You do not say anything about your sheet check boxes type... Please, test the next solution. It will be able to deal with both sheet check boxes type:
Copy this two Subs in a standard module:
Public Sub CheckUnCheckRow(Optional strName As String)
Dim sh As Worksheet, s As CheckBox, chK As OLEObject ' MSForms.CheckBox
Set sh = ActiveSheet
If strName <> "" Then
Set chK = sh.OLEObjects(strName) '.OLEFormat.Object
solveCheckRow chK.Object.Value, sh, Nothing, chK
Else
Set s = sh.CheckBoxes(Application.Caller)
solveCheckRow s.Value, sh, s
End If
End Sub
Sub solveCheckRow(boolVal As Long, sh As Worksheet, chF As CheckBox, Optional chK As OLEObject)
Dim s As CheckBox, oObj As OLEObject, iCount As Long
If Not chF Is Nothing Then
For Each s In sh.CheckBoxes
If chF.TopLeftCell.Address <> s.TopLeftCell.Address Then
If s.TopLeftCell.Row = chF.TopLeftCell.Row Then
s.Value = IIf(boolVal = -4146, 1, -4146): iCount = iCount + 1
If iCount = 2 Then Exit Sub
End If
End If
Next
ElseIf Not chK Is Nothing Then
For Each oObj In sh.OLEObjects
If oObj.TopLeftCell.Address <> chK.TopLeftCell.Address Then
If oObj.TopLeftCell.Row = chK.TopLeftCell.Row Then
boolStopEvents = True
oObj.Object.Value = IIf(boolVal = 0, True, False): iCount = iCount + 1
boolStopEvents = False
If iCount = 2 Then Exit Sub
End If
End If
Next
End If
End Sub
For case of Form check boxes type:
a). Manually assign the first sub to all your Form Type check boxes (right click - Assign Macro, choose CheckUnCheckRow and press OK).
b). Automatically assign the macro:
Dim sh As Worksheet, s As CheckBox
Set sh = ActiveSheet ' use here your sheet keeping the check boxes
For Each s In sh.CheckBoxes
s.OnAction = "'" & ThisWorkbook.Name & "'!CheckUnCheckRow"
Next
End Sub
If your check boxes have already assigned a macro, adapt CheckUnCheckRow, in Form check boxes section, to also call that macro...
For case of ActiveX check boxes:
a). Create a Public variable on top of a standard module (in the declarations area):
Public boolStopEvents
b). Manually adapt all your ActiveX check boxes Click or Change event, like in the next example:
Private Sub CheckBox1_Click()
If Not boolStopEvents Then CheckUnCheckRow "CheckBox1"
End Sub
Private Sub CheckBox2_Click()
If Not boolStopEvents Then CheckUnCheckRow "CheckBox2"
End Sub
Private Sub CheckBox3_Click()
If Not boolStopEvents Then CheckUnCheckRow "CheckBox3"
End Sub
and so on...
c). Or do all that with a click, using the next piece of code:
Sub createEventsAllActiveXCB()
Dim sh As Worksheet, oObj As OLEObject, strCode As String, ButName As String
Set sh = ActiveSheet 'use here your sheet keeping ActveX check boxes
For Each oObj In sh.OLEObjects
If TypeName(oObj.Object) = "CheckBox" Then
ButName = oObj.Name
strCode = "Private Sub " & ButName & "_Click()" & vbCrLf & _
" If Not boolStopEvents Then CheckUnCheckRow """ & ButName & """" & vbCrLf & _
"End Sub"
addClickEventsActiveXChkB sh, strCode
End If
Next
End Sub
Anyhow, the code cam be simplified in order to deal with only a type of such check boxes. If you intend to use it and looks too bushy, I can adapt it only for the type you like. Like it is, the code deals with both check box types, if both exist on the sheet...
Save the workbook and start playing with the check boxes. But, when you talk about check boxes on a row, all tree of them must have the same TopLeftCell.Row...
I am new to VBA and UserForms.
I have a ComboBox where the user will enter a unique Sales Order # (SalesOrder). I want my form to take this input and find it in the workbook and then update the status with the user's inputs in later ComboBoxes (CommentBox & OrderStatus). The issue I am facing is the actual code to find the Sales Order # in the workbook. I've tried what is seen below in several different variations.
If I replace all the ComboBox inputs with the actual inputs as a string, the code runs fine in a module.
Ideally, the code will loop through the sheet array finding all the lines with the Sales Order # and apply the inputs to the row.
Sub AddDataToList()
Dim shtarray As Variant, shtname As Variant
Dim Data As Worksheet, ws As Worksheet
Dim wbk As Workbook
Dim Strg As String
shtarray = Array("EMAUX", "Irene", "Cassandra", "Patricia", "EMREL", "Maria", "Jason", "Peedie", "MICRO", "PARTS", "NAVY", "DELTA")
Set wbk = ThisWorkbook
For Each shtname In shtarray
Set ws = Nothing
On Error Resume Next
Set ws = wbk.Worksheets(shtname)
On Error GoTo 0
If Not (ws Is Nothing) Then
ActiveSheet.Cells.Find(StatusUpdateForm.SalesOrder.Text).Offset(0, 17).Select
ActiveCell.Value = CommentBox.Text
ActiveCell.Offset(0, 2).Value = OrderStatus.Text
End If
Next
MsgBox SalesOrder.Value & "was updated."
End Sub
Thank you for the assistance!
More Information ***
Below is the code for the Update command button. This is a standard two button system, one updates the records and the other cancels the form.
Private Sub UpdateButton_Click()
If Not EverythingFilledIn Then Exit Sub
Me.Hide
AddDataToList
Unload Me
End Sub
And code for the EverthingFilledIn
Private Function EverythingFilledIn() As Boolean
Dim ctl As MSForms.Control
Dim AnythingMissing As Boolean
EverthingFilledIn = True
AnythingMissing = False
For Each ctl In Me.Controls
If TypeOf ctl Is MSForms.TextBox Or TypeOf ctl Is MSForms.ComboBox Then
If ctl.Value = "" Then
ctl.BackColor = rgbPink
Controls(ctl.Name & "Label").ForeColor = rgbRed
If Not AnythingMissing Then ctl.SetFocus
AnythingMissing = True
EverythingFilledIn = False
End If
End If
Next ctl
End Function
Try this (my first comment notwithstanding):
Sub AddDataToList()
Dim shtarray As Variant, shtname As Variant
Dim Data As Worksheet, ws As Worksheet
Dim wbk As Workbook
Dim Strg As String
Dim r As Range
shtarray = Array("EMAUX", "Irene", "Cassandra", "Patricia", "EMREL", "Maria", "Jason", "Peedie", "MICRO", "PARTS", "NAVY", "DELTA")
Set wbk = ThisWorkbook
For Each shtname In shtarray
Set ws = wbk.Worksheets(shtname)
Set r = ws.Cells.Find(StatusUpdateForm.SalesOrder.Text) 'better to specify all parameters
If Not r Is Nothing Then
r.Offset(0, 17).Value = CommentBox.Text
r.Offset(0, 2).Value = OrderStatus.Text
End If
Next
MsgBox SalesOrder.Value & "was updated."
End Sub
There is no need to select things.
I need this macro to generate 2 (or more) data columns from 2 (or more) cell references. Currently it only does one data series from one cell reference. The script generates a table and updates the table with a new data entry on each second, then updates a chart using the table data. The cell value is changing in real-time.
This should be a simple fix but I can't figure out the code. I'm out of my league. Any help would be awesome. Maybe somebody can refactor this or at least give me some hints as to what I should do.
Option Explicit
'Update the values between the quotes here:
Private Const sChartWSName = "Chart"
Private Const sSourceWSName = "Tickers"
Private Const sTableName = "tblValues"
Public RunTime As Double
Private Sub Chart_Setup()
'Create the structure needed to preserve and chart data
Dim wsChart As Worksheet
Dim lstObject As ListObject
Dim cht As Chart
Dim shp As Button
'Create sheet if necessary
Set wsChart = Worksheets.Add
wsChart.name = sChartWSName
'Set up listobject to hold data
With wsChart
.Range("A1").value = "Time"
.Range("B1").value = "Value"
Set lstObject = .ListObjects.Add( _
SourceType:=xlSrcRange, _
Source:=.Range("A1:B1"), _
xllistobjecthasheaders:=xlYes)
lstObject.name = sTableName
.Range("A2").NumberFormat = "h:mm:ss"
.columns("A:A").ColumnWidth = 25
.Select
End With
'Create the chart
With ActiveSheet
.Shapes.AddChart.Select
Set cht = ActiveChart
With cht
.ChartType = xlLine
.SetSourceData Source:=Range(sTableName)
.PlotBy = xlColumns
.Legend.Delete
.Axes(xlCategory).CategoryType = xlCategoryScale
With .SeriesCollection(1).Format.Line
.Visible = msoTrue
.Weight = 1.25
End With
End With
End With
'Add buttons to start/stop the routine
Set shp = ActiveSheet.Buttons.Add(242.25, 0, 83.75, 33.75)
With shp
.OnAction = "Chart_Initialize"
.Characters.Text = "Restart Plotting"
End With
Set shp = ActiveSheet.Buttons.Add(326.25, 0, 83.75, 33.75)
With shp
.OnAction = "Chart_Stop"
.Characters.Text = "Stop Plotting"
End With
End Sub
Public Sub Chart_Initialize()
'Initialize the routine
Dim wsTarget As Worksheet
Dim lstObject As ListObject
'Make sure worksheet exists
On Error Resume Next
Set wsTarget = Worksheets(sChartWSName)
If Err.Number <> 0 Then
Call Chart_Setup
Set wsTarget = Worksheets(sChartWSName)
End If
On Error GoTo 0
'Check if chart data exists
With Worksheets(sChartWSName)
Set lstObject = .ListObjects(sTableName)
If lstObject.ListRows.Count > 0 Then
Select Case MsgBox("You already have data. Do you want to clear it and start fresh?", vbYesNoCancel, "Clear out old data?")
Case Is = vbYes
'User wants to clear the data
lstObject.DataBodyRange.Delete
Case Is = vbCancel
'User cancelled so exit routine
Exit Sub
Case Is = vbNo
'User just wants to append to existing table
End Select
End If
'Begin appending
Call Chart_AppendData
End With
End Sub
Private Sub Chart_AppendData()
'Append data to the chart table
Dim lstObject As ListObject
Dim lRow As Long
With Worksheets(sChartWSName)
Set lstObject = .ListObjects(sTableName)
If lstObject.ListRows.Count = 0 Then
lRow = .Range("A1").End(xlDown).row
End If
If lRow = 0 Then
lRow = .Range("A" & .rows.Count).End(xlUp).offset(1, 0).row
End If
.Range("A" & lRow).value = CDate(Now)
.Range("B" & lRow).value = Worksheets(sSourceWSName).Range("M4").value
End With
RunTime = Now + TimeValue("00:00:01")
Application.OnTime RunTime, "Chart_AppendData"
End Sub
Public Sub Chart_Stop()
'Stop capturing data
On Error Resume Next
Application.OnTime EarliestTime:=RunTime, Procedure:="Chart_AppendData", Schedule:=False
End Sub
This is the snippet from "ThisWorkbook"
Private Sub Workbook_BeforeClose(Cancel As Boolean)
'Stop workbook refreshing
Call Chart_Stop
End Sub
I hope this helps.
Option Explicit
'Update the values between the quotes here:
Private Const sChartWSName = "Chart"
Private Const sSourceWSName = "Tickers"
Private Const sTableName = "tblValues"
Public RunTime As Double
Private Sub Chart_Setup()
'Create the structure needed to preserve and chart data
Dim wsChart As Worksheet
Dim lstObject As ListObject
Dim cht As Chart
Dim shp As Button
'Create sheet if necessary
Set wsChart = Worksheets.Add
wsChart.Name = sChartWSName
'Set up listobject to hold data
With wsChart
.Range("A1").Value = "Time"
.Range("B1").Value = "Value1"
'**** I added C! and changed "Value" to "Value1" and "Value2"
.Range("C1").Value = "Value2"
'**** I increased the range of the chart below to C1
Set lstObject = .ListObjects.Add( _
SourceType:=xlSrcRange, _
Source:=.Range("A1:C1"), _
xllistobjecthasheaders:=xlYes)
lstObject.Name = sTableName
.Range("A2").NumberFormat = "h:mm:ss"
.Columns("A:A").ColumnWidth = 25
.Select
End With
'Create the chart
With ActiveSheet
.Shapes.AddChart.Select
Set cht = ActiveChart
With cht
.ChartType = xlLine
.SetSourceData Source:=Range(sTableName)
.PlotBy = xlColumns
.Legend.Delete
.Axes(xlCategory).CategoryType = xlCategoryScale
With .SeriesCollection(1).Format.Line
.Visible = msoTrue
.Weight = 1.25
End With
End With
End With
'Add buttons to start/stop the routine
Set shp = ActiveSheet.Buttons.Add(242.25, 0, 83.75, 33.75)
With shp
.OnAction = "Chart_Initialize"
.Characters.Text = "Restart Plotting"
End With
Set shp = ActiveSheet.Buttons.Add(326.25, 0, 83.75, 33.75)
With shp
.OnAction = "Chart_Stop"
.Characters.Text = "Stop Plotting"
End With
End Sub
Public Sub Chart_Initialize()
'Initialize the routine
Dim wsTarget As Worksheet
Dim lstObject As ListObject
'Make sure worksheet exists
On Error Resume Next
Set wsTarget = Worksheets(sChartWSName)
If Err.Number <> 0 Then
Call Chart_Setup
Set wsTarget = Worksheets(sChartWSName)
End If
On Error GoTo 0
'Check if chart data exists
With Worksheets(sChartWSName)
Set lstObject = .ListObjects(sTableName)
If lstObject.ListRows.Count > 0 Then
Select Case MsgBox("You already have data. Do you want to clear it and start fresh?", vbYesNoCancel, "Clear out old data?")
Case Is = vbYes
'User wants to clear the data
lstObject.DataBodyRange.Delete
Case Is = vbCancel
'User cancelled so exit routine
Exit Sub
Case Is = vbNo
'User just wants to append to existing table
End Select
End If
'Begin appending
Call Chart_AppendData
End With
End Sub
Public Sub Chart_AppendData()
'Append data to the chart table
Dim lstObject As ListObject
Dim lRow As Long
With Worksheets(sChartWSName)
Set lstObject = .ListObjects(sTableName)
If lstObject.ListRows.Count = 0 Then
lRow = .Range("A1").End(xlDown).Row
End If
If lRow = 0 Then
lRow = .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).Row
End If
.Range("A" & lRow).Value = CDate(Now)
.Range("B" & lRow).Value = 4
.Range("C" & lRow).Value = 5
'******I used the two line above to test results, uncomment the line below and feel free to change M5 to any other renge location workd best for you
' .Range("B" & lRow).Value = Worksheets(sSourceWSName).Range("M4").Value
' .Range("C" & lRow).Value = Worksheets(sSourceWSName).Range("M5").Value
End With
RunTime = Now + TimeValue("00:00:01")
Application.OnTime RunTime, "Chart_AppendData"
End Sub
Public Sub Chart_Stop()
'Stop capturing data
On Error Resume Next
Application.OnTime EarliestTime:=RunTime, Procedure:="Chart_AppendData", Schedule:=False
End Sub
How to make suggestions in Excel data validation list while typing. There are constraints in my request:
The list of items should be in another sheet, and must not be above in hidden rows.
Typing a phrase should narrow the list to all the items which contain the phrase.
Search should be case insensitive.
So after typing am we should hypothetically have a suggestion to pick up from Amelia, Camila, Samantha, provided that those girls' names are on the item list.
I have found a good solution here, however it does not filter the items with contains clause but begins with. I sum up the proposed solution here shortly.
We insert a Combo Box (ActiveX Control) to a sheet.
We right click on a sheet name > View code > and paste the VBA code in the sheet VBA editor:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'Update by Extendoffice: 2018/9/21
Dim xCombox As OLEObject
Dim xStr As String
Dim xWs As Worksheet
Dim xArr
Set xWs = Application.ActiveSheet
On Error Resume Next
Set xCombox = xWs.OLEObjects("TempCombo")
With xCombox
.ListFillRange = ""
.LinkedCell = ""
.Visible = False
End With
If Target.Validation.Type = 3 Then
Target.Validation.InCellDropdown = False
Cancel = True
xStr = Target.Validation.Formula1
xStr = Right(xStr, Len(xStr) - 1)
If xStr = "" Then Exit Sub
With xCombox
.Visible = True
.Left = Target.Left
.Top = Target.Top
.Width = Target.Width + 5
.Height = Target.Height + 5
.ListFillRange = xStr
If .ListFillRange = "" Then
xArr = Split(xStr, ",")
Me.TempCombo.List = xArr
End If
.LinkedCell = Target.Address
End With
xCombox.Activate
Me.TempCombo.DropDown
End If
End Sub
Private Sub TempCombo_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Select Case KeyCode
Case 9
Application.ActiveCell.Offset(0, 1).Activate
Case 13
Application.ActiveCell.Offset(1, 0).Activate
End Select
End Sub
I could not find a way to modify to change the search option from 'begins with' to contains.
The questions about autocomplete or autosuggest in validation list have been asked so far.
Excel data validation with suggestions/autocomplete
Excel 2010: how to use autocomplete in validation list
But neither of them contained answers which would satisfied the constraints I imposed.
Test file for download is here.
Try to add the following event (additionally the the other 2). Every time you enter something the code refreshes the ComboBox list.
Private Sub TempCombo_Change()
With Me.TempCombo
If Not .Visible Then Exit Sub
.Clear 'needs property MatchEntry set to 2 - fmMatchEntryNone
.Visible = False 'to refresh the drop down
.Visible = True
.Activate
Dim xStr As String, xArr As Variant
xStr = TempCombo.TopLeftCell.Validation.Formula1
xStr = Right(xStr, Len(xStr) - 1)
xArr = Split(xStr, Application.International(xlListSeparator))
Dim itm As Variant
For Each itm In xArr
If InStr(1, itm, .Value, vbTextCompare) > 0 Or .Value = "" Then
.AddItem itm
End If
Next itm
.DropDown
End With
End Sub
To overcome your first constraint, maybe you can assign a range to your combo box:
Dim xCombox As OLEObject
Dim xStr As String
Dim xWs As Worksheet
Dim xArr
Dim i As Range
Set xWs = Application.ActiveSheet
On Error Resume Next
Set xCombox = xWs.OLEObjects("Combotest")
With Sheets("Test_list2")
Set i = .Range("A2:A" & .Range("A" & .Rows.Count).End(xlUp).Row)
End With
Combotest.ListFillRange = i.Address
Set xWs = Application.ActiveSheet
On Error Resume Next
Set xCombox = xWs.OLEObjects("Combotest")
With xCombox
.LinkedCell = "F2"
.Visible = True
End With
.
.
.
.
End Sub