I have a column in a table that will contain entire phrases with difficult words ("hypothetical exemplification of those akiophrastic words"). I have a list of most words that I expect will be used there.
I found a great solution here but it doesn't quite match my usecase. It works if you want to choose the content of your cell from a list of choices. I want to be able to get suggestions for the currently-typed word within the cell. So I write "hypoth" and click "hypothetical" from the dropdown, then I hit spacebar and start writing "exem" and want to get suggestions for that as well, and so on.
I will try changing the VBA code provided in my hyperlink above but I'm not sure I'll be successful. I'm open to any suggestion. It can also involve userforms although I doubt there is a way using them.
EDIT: On request, I'm summarizing the linked tutorial and posting its code.
It makes you create a Combo Box from the developer tools tab and name it TempCombo.
In the code for the worksheet, where the box is located, you write the following code:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'Update by Extendoffice: 2020/01/16
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
Using the linked code from my OP and Tim Williams's excellent code, this is the result I got to. To use this, you will have to adapt some lines. There were some really odd bugs which I fixed by adapting some parts. Also added control functionality with Return (+Shift), up and down keys.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim xText As OLEObject
Dim xStr As String
Dim xList As OLEObject
Dim xWs As Worksheet
Dim xArr
Dim ListTarget As Range
' Suggestion box placement
Set ListTarget = Target.Offset(2, 1)
Set xWs = Application.ActiveSheet
On Error Resume Next
Set xText = xWs.OLEObjects("txt1")
Set xList = xWs.OLEObjects("lstMatches")
' Every click lets the boxes disappear.
With xText
.ListFillRange = ""
.LinkedCell = ""
.Visible = False
End With
With xList
.ListFillRange = ""
.LinkedCell = ""
.Visible = False
End With
' Restrict where you want this functionality in your sheet here
If Target.Validation.Type = 3 And Target.column = 10 And Target.row > 4 Then
Target.Validation.InCellDropdown = False
xStr = Target.Validation.Formula1
xStr = Right(xStr, Len(xStr) - 1)
If xStr = "" Then Exit Sub
With xText
.Visible = True
.Left = Target.Left
.Top = Target.Top
.Width = Target.Width + 200 ' Size of text box
.Height = Target.Height + 5 ' Make it a little taller for better readability
.ListFillRange = ""
'If .ListFillRange = "" Then
'xArr = Split(xStr, ",")
'Me.TempCombo.list = xArr
'End If
.LinkedCell = Target.Address
End With
With xList
.Visible = True
.Left = ListTarget.Left
.Top = ListTarget.Top
.Width = ListTarget.Width + 200 ' Size of suggestions box
.Height = ListTarget.Height + 100
If .ListFillRange = "" Then 'This loop fills the suggestions with the list from the validation formula, unless already changed by input
xArr = Split(xStr, ",")
xList.ListFillRange = xArr
End If
End With
xText.Activate
Me.lstMatches.Locked = False ' It randomly locked for me, just in case.
' The following two lines fix an obscure bug that made the suggestions un-clickable at random.
ActiveWindow.SmallScroll ToLeft:=1
ActiveWindow.SmallScroll ToRight:=1
End If
End Sub
Private Sub lstMatches_Click()
Dim word, pos As Long
word = Me.lstMatches.value
suspend = True ' disables the text change function for programmatic changes
'try to replace the last "word" (or part of word) with the selected word
pos = InStrRev(Me.txt1.text, " ")
If pos > 0 Then
Me.txt1.text = Left(Me.txt1.text, pos) & word
Else
Me.txt1.text = word
End If
Me.txt1.Activate
suspend = False
End Sub
Private Sub txt1_Change()
Dim txt As String, arr, last As String, allWords, r As Long
Dim data_lastRow As Long
data_lastRow = Worksheets("my_data").Cells(2, 5).End(xlDown).row
If suspend Then Exit Sub 'don't respond to programmatic changes
txt = Trim(Me.txt1.text)
If Len(txt) = 0 Then
Me.lstMatches.Clear
Exit Sub
End If
arr = Split(txt, " ")
last = arr(UBound(arr))
If Len(last) > 1 Then
allWords = Worksheets("my_data").Range("E2:E" & CStr(data_lastRow)).value 'get the words list
Me.lstMatches.Clear
For r = 1 To UBound(allWords)
If allWords(r, 1) Like last & "*" Then 'match on "starts with"
Me.lstMatches.AddItem allWords(r, 1)
If Me.lstMatches.ListCount = 15 Then Exit Sub ' limiting it to 15 suggestions
End If
Next r
End If
End Sub
Private Sub txt1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Select Case KeyCode
Case 13
If Shift = 0 Then
Application.ActiveCell.Offset(1, 0).Activate
Else
Application.ActiveCell.Offset(-1, 0).Activate
End If
Case vbKeyDown
Application.ActiveCell.Offset(1, 0).Activate
Case vbKeyUp
Application.ActiveCell.Offset(-1, 0).Activate
Case vbKeyLeft
Application.ActiveCell.Offset(0, -1).Activate
End Select
End Sub