Question

我有一个用户表单，可以搜索工作表上的信息。它应该在名为＆＃34; lbSrchMatchingResults＆＃34;;的列表框中显示与搜索条件匹配的行。不幸的是，它只显示每个匹配行的第一列。我的解决方案基于CPearson（http://www.cpearson.com/excel/findall.aspx）和Jon Acampora（http://www.excelcampus.com/tools/find-all-vba-form-for-excel/）提供的代码。负责填充列表框的子程序如下所示：

Private Sub FindAllMatches()
'Find all matches on activesheet

Dim SearchRange As Range
Dim FindWhat As Variant
Dim FoundCells As Range
Dim FoundCell As Range
Dim arrResults() As Variant
Dim lFound As Long
Dim lSearchCol As Long
Dim lLastRow As Long
Dim rw As Range, c As Long  '<<<< added

'Do search if text in find box is longer than 1 character.
If Len(FSearchAssets.tbSrchSearchString.Value) > 1 Then

    Set SearchRange = ActiveSheet.UsedRange.Cells

    FindWhat = FSearchAssets.tbSrchSearchString.Value
    'Calls the FindAll function
    Set FoundCells = FindAll(SearchRange:=SearchRange, _
                            FindWhat:=FindWhat, _
                            LookIn:=xlValues, _
                            LookAt:=xlPart, _
                            SearchOrder:=xlByColumns, _
                            MatchCase:=False, _
                            BeginsWith:=vbNullString, _
                            EndsWith:=vbNullString, _
                            BeginEndCompare:=vbTextCompare)
    If FoundCells Is Nothing Then
        ReDim arrResults(1 To 1, 1 To 2)
        arrResults(1, 1) = "No Results"
    Else
        'Add results of FindAll to an array
        ReDim arrResults(1 To FoundCells.Count, 1 To 14)
        lFound = 1
        For Each FoundCell In FoundCells

            'add the matching value and address
            'arrResults(lFound, 1) = FoundCell.Value
            'arrResults(lFound, 2) = FoundCell.Address

            Set rw = FoundCell.EntireRow 'get the full row for the found cell
            'add the first 13 values from that row to the listbox
            For c = 1 To 13
                'arrResults(lFound, 2 + c) = rw.Cells(c).Value
                arrResults(lFound, c) = rw.Cells(c).Value
            Next c

            lFound = lFound + 1
        Next FoundCell
    End If

    'Populate the listbox with the array
    Me.lbSrchMatchingResults.List = arrResults
Else
    Me.lbSrchMatchingResults.Clear
End If
End Sub

Answer 1

将列表框列数设置为14，然后尝试：

Private Sub FindAllMatches()
'Find all matches on activesheet

    Dim SearchRange As Range
    Dim FindWhat As Variant
    Dim FoundCells As Range
    Dim FoundCell As Range
    Dim arrResults() As Variant
    Dim lFound As Long
    Dim lSearchCol As Long
    Dim lLastRow As Long
    Dim rw As Range, c As Long  '<<<< added

    'Do search if text in find box is longer than 1 character.
    If Len(FSearchAssets.tbSrchSearchString.Value) > 1 Then 

        Set SearchRange = ActiveSheet.UsedRange.Cells

        FindWhat = FSearchAssets.tbSrchSearchString.Value
        'Calls the FindAll function
        Set FoundCells = FindAll(SearchRange:=SearchRange, _
                                FindWhat:=FindWhat, _
                                LookIn:=xlValues, _
                                LookAt:=xlPart, _
                                SearchOrder:=xlByColumns, _
                                MatchCase:=False, _
                                BeginsWith:=vbNullString, _
                                EndsWith:=vbNullString, _
                                BeginEndCompare:=vbTextCompare)
        If FoundCells Is Nothing Then
            ReDim arrResults(1 To 1, 1 To 2)
            arrResults(1, 1) = "No Results"
        Else
            'Add results of FindAll to an array
            ReDim arrResults(1 To FoundCells.Count, 1 To 14)
            lFound = 1
            For Each FoundCell In FoundCells

                'add the matching value and address
                arrResults(lFound, 1) = FoundCell.Value
                arrResults(lFound, 2) = FoundCell.Address

                Set rw = FoundCell.EntireRow 'get the full row for the found cell
                'add the first 12 values from that row to the listbox
                For c = 1 To 12
                    arrResults(lFound, 2 + c) = rw.Cells(c).Value
                Next c

                lFound = lFound + 1
            Next FoundCell
        End If

        'Populate the listbox with the array
        Me.lbSrchMatchingResults.List = arrResults
    Else
        Me.lbSrchMatchingResults.Clear
    End If
End Sub

列表框中显示多行，但列表框中仅显示工作表中的一列

1 个答案: