如何在 Excel 中的一个单元格内实现逐字预测文本？
How to implement word-for-word predictive text within one cell in Excel?
我在 table 中有一个专栏，其中将包含带有难词的整个短语（“这些反语词的假设示例”）。我有一个列表，其中包含我希望在那里使用的最多的单词。
我找到了一个很好的解决方案 here 但它与我的用例不太匹配。如果您想从选项列表中选择单元格的内容，它会起作用。我希望能够获得有关单元格中当前键入的单词的建议。所以我写了“hypoth”并从下拉列表中单击“hypothetical”，然后我按下空格键并开始写“exem”并希望获得相关建议，依此类推。
我将尝试更改上面超链接中提供的 VBA 代码，但我不确定是否会成功。我愿意接受任何建议。它也可以涉及用户表单，尽管我怀疑是否有使用它们的方法。
编辑：根据要求，我总结了链接的教程并发布了它的代码。
它使您可以从开发人员工具选项卡创建一个组合框并将其命名为 TempCombo。
在框所在的工作表代码中，编写以下代码：
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
这是一个在工作表上使用文本框 (txt1) 和列表框 (lstMatches) 的非常基本的示例：
Option Explicit
Dim suspend As Boolean
Private Sub lstMatches_Click()
Dim word, pos As Long
word = Me.lstMatches.Value
suspend = True
'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
If suspend Then Exit Sub 'don't respond to programmatic changes
txt = Trim(Me.txt1.Text)
If Len(txt) = 0 Then 'is there any text?
Me.lstMatches.Clear
Exit Sub
End If
arr = Split(txt, " ")
last = arr(UBound(arr)) 'get the last word
If Len(last) > 1 Then
allWords = Me.Range("words").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)
End If
Next r
End If
End Sub
使用我的 OP 中的链接代码和 Tim Williams 的优秀代码，这就是我得到的结果。要使用它，您必须调整一些行。我通过调整某些部分修复了一些非常奇怪的错误。还添加了使用 Return (+Shift)、向上和向下键的控制功能。
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
我在 table 中有一个专栏，其中将包含带有难词的整个短语（“这些反语词的假设示例”）。我有一个列表，其中包含我希望在那里使用的最多的单词。
我找到了一个很好的解决方案 here 但它与我的用例不太匹配。如果您想从选项列表中选择单元格的内容，它会起作用。我希望能够获得有关单元格中当前键入的单词的建议。所以我写了“hypoth”并从下拉列表中单击“hypothetical”，然后我按下空格键并开始写“exem”并希望获得相关建议，依此类推。
我将尝试更改上面超链接中提供的 VBA 代码，但我不确定是否会成功。我愿意接受任何建议。它也可以涉及用户表单，尽管我怀疑是否有使用它们的方法。
编辑：根据要求，我总结了链接的教程并发布了它的代码。
它使您可以从开发人员工具选项卡创建一个组合框并将其命名为 TempCombo。
在框所在的工作表代码中，编写以下代码：
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
这是一个在工作表上使用文本框 (txt1) 和列表框 (lstMatches) 的非常基本的示例：
Option Explicit
Dim suspend As Boolean
Private Sub lstMatches_Click()
Dim word, pos As Long
word = Me.lstMatches.Value
suspend = True
'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
If suspend Then Exit Sub 'don't respond to programmatic changes
txt = Trim(Me.txt1.Text)
If Len(txt) = 0 Then 'is there any text?
Me.lstMatches.Clear
Exit Sub
End If
arr = Split(txt, " ")
last = arr(UBound(arr)) 'get the last word
If Len(last) > 1 Then
allWords = Me.Range("words").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)
End If
Next r
End If
End Sub
使用我的 OP 中的链接代码和 Tim Williams 的优秀代码，这就是我得到的结果。要使用它，您必须调整一些行。我通过调整某些部分修复了一些非常奇怪的错误。还添加了使用 Return (+Shift)、向上和向下键的控制功能。
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