多页自动补全搜索

时间:2019-07-17 11:32:18

标签: excel vba

我正在尝试在vba中开发一种搜索功能(自动完成样式),该功能将在来自两个不同工作表的两列中查找字符串。

例如: 包含基本列表的工作表之一(另一个具有相同的结构):

enter image description here

我要进行自动补全搜索的工作表。 enter image description here

谷歌搜索了一下之后,发现下面的代码似乎很适合我的需求:

Private Sub Worksheet_Change(ByVal Target As Range)
  'Sub "autocompletes" data entered into column A using a source table on a different worksheet. If more than one match is
 '    found, the user is allowed to continue entering characters until a unique match is found. If no matches are found, the
 '    data is accepted as entered. ALT + Enter, Enter to force the macro to accept data as entered. The sub is triggered by
 '    the Enter key.
Dim cel As Range, match1 As Range, match2 As Range, rg As Range, targ As Range


Set targ = Intersect(Target, Worksheets("FT_CASE_xx").Range("A:A"))
Set rg = Worksheets("DEF_BOOLEAN").Range("A:A")

If targ Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Application.EnableEvents = False
On Error GoTo errhandler 'If code encounters an error, turn events back on

For Each cel In targ
    If Not IsError(cel) Then
        If cel <> "" And Right(cel, 1) <> Chr(10) Then
            Set match1 = Nothing
            Set match1 = rg.Find(cel & "*", lookat:=xlWhole, MatchCase:=False) 'Match is case insensitive
            If Not match1 Is Nothing Then
                Set match2 = rg.FindNext(after:=match1)
                If match2.Address = match1.Address Then 'Code is fooled by identical strings in two cells
                    cel = match1 'Only one match found. Use it to "autocomplete" the cell
                Else 'More than one match found. User must enter more data. Return to "Edit" mode
                    cel.Activate
                    Application.SendKeys ("{F2}") 'Begin editing after last character entered
                End If
            Else 'No matches found. Do not change entered text
            End If
        Else 'Strip the line feed from the end of the text string
            If cel <> "" And Right(cel, 1) = Chr(10) Then cel = Left(cel, Len(cel) - 1)
        End If
    End If
Next cel

errhandler:     Application.EnableEvents = True
    On Error GoTo 0
    Application.ScreenUpdating = True
    End Sub

虽然我在键入字符串,但似乎可行,因为如果还有更多可行的选择(例如,Write B_FTE返回超过1个匹配项),我无法按Enter键,那么无论如何它不会显示任何下拉列表来选择值(因此不是很有用)。

源代码:enter link description here

0 个答案:

没有答案