Question

我试图找出过滤或搜索包含多个列和多行的用户窗体中包含的列表框所需的代码。在userform上，我有一个允许用户输入的文本框，理想情况下会从Listbox中过滤掉不匹配的条目。

我找到a few solutions online，但我无法在用户表单中包含多列的列表框上工作。它从示例中编码的方式是尝试转置单列数据，我猜测我需要更改代码才能使用数组。我对VBA还不够强大，无法确切知道如何改变这一部分。

我也在GoToRow（）函数上收到错误，但我认为它与单列和多列列表框问题有关。

我已经在下面添加了一个指向我项目基本模型的链接，因为我使用的是带有名单的列表框和文本框的用户表单。

https://www.dropbox.com/s/diu05ncwbltepqp/BasicListboxExample.xlsm?dl=0

我的userform上的列表框有五列，名为ProjectList，文本框名为SearchTextBox。

Option Explicit
Const ProjectNameCol = "B"
Dim PS As Worksheet
Private loActive As Excel.ListObject

Private Sub UserForm_Activate() ' Main code on Userform Activation, calls support subs

    Set PS = Sheets("ProjectSheet") 'stores value for Project Sheet Worksheet as PS
    Set loActive = ActiveSheet.ListObjects(1)

    'populates listbox with data from ProjectSheet Worksheet named table
    ProjectList.RowSource = "AllData"

    '# of Columns for listbox
    ProjectList.ColumnCount = 5

    'Column Width for listbox
    ProjectList.ColumnWidths = "140; 100; 100; 100; 100"

    Me.ProjectList.TextColumn = 1
    Me.ProjectList.MatchEntry = fmMatchEntryComplete
    ResetFilter

End Sub

Private Sub SearchTextBox_Change()
    'Can't get anything to work here
    ResetFilter
End Sub

Sub ResetFilter()

Dim rngTableCol As Excel.Range
Dim varTableCol As Variant
Dim RowCount As Long
Dim FilteredRows() As String
Dim i As Long
Dim ArrCount As Long
Dim FilterPattern As String

'the asterisks make it match anywhere within the string
If Not ValidLikePattern(Me.SearchTextBox.Text) Then
    Exit Sub
End If
FilterPattern = "*" & Me.SearchTextBox.Text & "*"

Set rngTableCol = loActive.ListColumns(1).DataBodyRange
'note that Transpose won't work with > 65536 rows
varTableCol = Application.WorksheetFunction.Transpose(rngTableCol.value)
RowCount = UBound(varTableCol)
ReDim FilteredRows(1 To 2, 1 To RowCount)
For i = 1 To RowCount
        'Like operator is case sensitive,
        'so need to use LCase if not CaseSensitive
        If (LCase(varTableCol(i)) Like LCase(FilterPattern)) Then
            'add to array if ListBox item matches filter
            ArrCount = ArrCount + 1
            'there's a hidden ListBox column that stores the record num
            FilteredRows(1, ArrCount) = i
            FilteredRows(2, ArrCount) = varTableCol(i)
        End If
Next i
If ArrCount > 0 Then
    'delete empty array items
    'a ListBox cannot contain more than 65536 items
    ReDim Preserve FilteredRows(1 To 2, 1 To Application.WorksheetFunction.Min(ArrCount, 65536))
Else
    're-initialize the array
    Erase FilteredRows
End If
If ArrCount > 1 Then
    Me.ProjectList.List = Application.WorksheetFunction.Transpose(FilteredRows)
Else
    Me.ProjectList.Clear
    'have to add separately if just one match
    'or we get two rows, not two columns, in ListBox
    If ArrCount = 1 Then
        Me.ProjectList.AddItem FilteredRows(1, 1)
        Me.ProjectList.List(0, 1) = FilteredRows(2, 1)
    End If
End If
End Sub

Private Sub ProjectList_Change()
GoToRow
End Sub

Sub GoToRow()
If Me.ProjectList.ListCount > 0 Then
    Application.Goto loActive.ListRows(Me.ProjectList.value).Range.Cells(1),True
End If
End Sub

在我的模块中，我有：

Function ValidLikePattern(LikePattern As String) As Boolean
Dim temp As Boolean
On Error Resume Next
temp = ("A" Like "*" & LikePattern & "*")
If Err.Number = 0 Then
    ValidLikePattern = True
End If
On Error GoTo 0
End Function

Excel VBA - 通过文本框

0 个答案: