Excel VBA中具有自动完成/建议的下拉列表 [英] dropdown list with autocomplete/ suggestion in excel vba

问题描述

在合并的单元格(名为SelName)中，我有一个下拉列表，其中包含100多个项目.搜索列表效率不高，因为此列表在不断增长.因此，我想要一个带有自动完成/建议功能的下拉列表.我拥有的代码之一是在extendoffice.com上找到的以下代码:

In a merged cell (named as SelName) I have a dropdown list with more then 100 items. Searching through the list is not efficient, as this list is constantly growing. Therefore, I would like to have a dropdown list with autocomplete/ suggestion function. One of the codes that I have is the following which I have found on extendoffice.com:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'Update by Extendoffice: 2017/8/15
Dim xCombox As OLEObject
Dim xStr As String
Dim xWs As Worksheet
Dim Cancel As Boolean
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
        .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

首先，我尝试在一个空白表(仅包含下拉列表)中对其进行测试，并且效果很好.但是，一旦我尝试将此代码插入到其他工作表中，它就没有.有谁知道可能是什么问题?仅供参考:我在此工作表中有几个下拉列表，所有这些下拉列表都在合并的单元格中.此外，我还有其他一些私人订阅...

First, I tried to test it in an empty sheet (with just the dropdown list) and it worked well. But as soon as I try to insert this code into the other worksheet, it doesn't. Does anyone has an idea what the problem could be? FYI: I have several drop down lists in this worksheet and all of them are in merged cells. Additionally, I have some other Private subs...

推荐答案

为什么必须这样做，而不是仅仅创建ComboBox控件并设置 ListFillRange 和 LinkedCell 没有任何代码?

Why do you have to do that instead of just creating a ComboBox control and setting ListFillRange and LinkedCell without any code?

发生错误是因为您正在编辑的范围( Target )没有任何验证.您应添加检查支票:

The error happens because the Range you are editing (Target) does not have any Validation. You should add the check for validation:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim vType As XlDVType
    On Error GoTo EndLine
    vType = Target.Validation.Type

    Dim xCombox As OLEObject
    Dim xStr As String
    Dim xWs As Worksheet
    Dim Cancel As Boolean
    Set xWs = Application.ActiveSheet

    'On Error Resume Next
    Set xCombox = xWs.OLEObjects("TempCombo")
    With xCombox
        .ListFillRange = ""
        .LinkedCell = ""
        .Visible = False
    End With
    If vType = 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
            .LinkedCell = Target.Address
        End With
        xCombox.Activate
        Me.TempCombo.DropDown
    End If
EndLine:
End Sub

编辑

如果我正确理解了该问题，则需要一个可从列自动填充并在列中键入更多条目时自动更新的ComboBox.不需要如此复杂的代码.您可以简单地添加一个ComboBox(例如ComboBox1)，设置其ListFillRange(例如， A1:A20 )，然后执行以下操作:

If i understand the problem correctly, you want a ComboBox that auto-fills from a column and auto-updates if you type more entries in the column. There is no need for such complicated code. You can simply add a ComboBox (say ComboBox1), set its ListFillRange (e.g. to A1:A20) and do this:

    Private Sub Worksheet_SelectionChange(ByVal Target As Range)
        With ComboBox1
            Dim OrigRange As Range: OrigRange = .ListFillRange
            If Not Application.Intersect(OrigRange, Target) Is Nothing Then
                .ListFillRange = .OrigRange.Resize(OrigRange.Cells(1).End(xlDown).Row - OrigRange.Row + 1)
            End If
        End With
    End Sub

这篇关于Excel VBA中具有自动完成/建议的下拉列表的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！