如何实现基于单列关键词的TextBox单词级自动补全功能

针对你遇到的问题——原代码会补全整个单元格内容而非单个关键词，且无法过滤重复关键词，以下是修改后的解决方案：

核心思路 #

1. 遍历目标列的所有单元格，拆分每个单元格中逗号分隔的关键词
2. 利用集合自动去重的特性，提取所有唯一关键词
3. 在文本框输入时，匹配以输入内容开头的单个关键词，实现精准补全

完整代码 #

' 辅助函数：提取目标列中所有唯一的关键词（逗号分隔）
Private Function GetUniqueKeywords() As Variant
    Dim ws As Worksheet
    Dim tbl As ListObject
    Dim dataRange As Range
    Dim cell As Range
    Dim keywordsArr As Variant
    Dim keyword As String
    Dim uniqueKeywords As New Collection
    
    Set ws = ThisWorkbook.Worksheets("Base de données")
    Set tbl = ws.ListObjects("RCA")
    Set dataRange = tbl.ListColumns("Date constatation NC").DataBodyRange
    
    ' 遍历每个单元格，拆分关键词并去重
    For Each cell In dataRange
        If cell.Value <> "" Then
            keywordsArr = Split(cell.Value, ",")
            For Each keyword In keywordsArr
                ' 去除关键词前后空格，避免因空格导致的重复
                keyword = Trim(keyword)
                If keyword <> "" Then
                    On Error Resume Next ' 集合已存在时跳过报错
                    uniqueKeywords.Add keyword, Key:=keyword
                    On Error GoTo 0
                End If
            Next keyword
        End If
    Next cell
    
    ' 将集合转为数组返回
    Dim resultArr() As String
    ReDim resultArr(1 To uniqueKeywords.Count)
    For i = 1 To uniqueKeywords.Count
        resultArr(i) = uniqueKeywords(i)
    Next i
    GetUniqueKeywords = resultArr
End Function

' 文本框KeyUp事件：实现单个关键词自动补全
Private Sub TextBoxDT_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    Dim searchString As String
    Dim allKeywords As Variant
    Dim i As Integer
    Dim matchedKeyword As String
    
    searchString = Trim(TextBoxDT.Text)
    If searchString = "" Then Exit Sub
    
    ' 获取所有唯一关键词
    allKeywords = GetUniqueKeywords()
    
    ' 查找以输入字符串开头的关键词
    matchedKeyword = ""
    For i = LBound(allKeywords) To UBound(allKeywords)
        If LCase(allKeywords(i)) Like LCase(searchString) & "*" Then
            matchedKeyword = allKeywords(i)
            Exit For
        End If
    Next i
    
    ' 找到匹配项则补全
    If matchedKeyword <> "" Then
        TextBoxDT.Text = matchedKeyword
        TextBoxDT.SelStart = Len(searchString)
        TextBoxDT.SelLength = Len(matchedKeyword) - Len(searchString)
    End If
End Sub

关键说明 #

• GetUniqueKeywords函数：通过遍历单元格拆分关键词，用集合自动去重，最后转为数组供补全使用。加入Trim(keyword)处理，避免关键词前后空格导致的重复或匹配错误。
• KeyUp事件：先获取输入的字符串，遍历所有唯一关键词，找到第一个以输入内容开头的关键词，然后替换文本框内容并选中补全部分，实现和原代码类似的补全体验，但针对单个关键词。

内容的提问来源于stack exchange，提问作者clebardkleber