Question

你好我在我的VBA中有这个搜索框和列表框，并且非常适合搜索数据，但是我不会在necel中显示更多列，并在excel中定价它们你好我在列表框中有这个搜索并且很适合按数据搜索但我想在列表框中显示更多列，例如从excel加载列

Option Explicit
Private loActive As Excel.ListObject
Private Sub UserForm_Activate()
Set loActive = ActiveSheet.ListObjects(1)
Me.lstDetail.TextColumn = 2
Me.lstDetail.MatchEntry = fmMatchEntryComplete
End Sub
Sub ResetFilter()
Dim rngTableCol As Excel.Range
Dim varTableCol As Variant
Dim RowCount As Long
Dim collUnique As Collection
Dim FilteredRows() As String
Dim i As Long
Dim ArrCount As Long
Dim FilterPattern As String
Dim UniqueValuesOnly As Boolean
Dim UniqueConstraint As Boolean
Dim CaseSensitive As Boolean
'the asterisks make it match anywhere within the string
If Not ValidLikePattern(Me.txtFilter.Text) Then
    Exit Sub
End If
FilterPattern = "*" & Me.txtFilter.Text & "*"
UniqueValuesOnly = Me.chkUnique.Value
CaseSensitive = Me.chkCaseSensitive
'used only if UniqueValuesOnly is true
Set collUnique = New Collection
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
    If UniqueValuesOnly Then
        On Error Resume Next
        'reset for this loop iteration
        UniqueConstraint = False
        'Add fails if key isn't UniqueValuesOnly
        collUnique.Add Item:="test", Key:=CStr(varTableCol(i))
        If Err.Number <> 0 Then
            UniqueConstraint = True
        End If
        On Error GoTo 0
    End If
    'True if UniqueValuesOnly is false or if
    'UniqueValuesOnly is True and this is the
    'first occurrence of the item
    If Not UniqueConstraint Then
        'Like operator is case sensitive,
        'so need to use LCase if not CaseSensitive
        If (Not CaseSensitive And LCase(varTableCol(i)) Like     LCase(FilterPattern)) _
           Or (CaseSensitive And varTableCol(i) Like 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
    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.lstDetail.List = Application.WorksheetFunction.Transpose(FilteredRows)
Else
    Me.lstDetail.Clear
    'have to add separately if just one match
    'or we get two rows, not two columns, in ListBox
    If ArrCount = 1 Then
        Me.lstDetail.AddItem FilteredRows(0, 1)
        Me.lstDetail.List(0, 1) = FilteredRows(2, 1)
    End If
End If
End Sub

Private Sub txtFilter_Change()
ResetFilter
End Sub

Private Sub chkCaseSensitive_Click()
ResetFilter
End Sub
Private Sub chkUnique_Click()
ResetFilter
End Sub

Answer 1

这是如何通过迭代表来填充列表框中的多个列的简约示例。

Private loActive As Excel.ListObject

Private Sub Example()

    Dim r As Range
    Dim i As Integer

    lstDetail.ColumnCount = 6
    lstDetail.ColumnWidths = ""

    Set loActive = ActiveSheet.ListObjects(1)

    For Each r In loActive.ListColumns(1).Range

        lstDetail.AddItem r.Value
        i = lstDetail.ListCount - 1

        lstDetail.List(i, 1) = r.Cells(1, "B")
        lstDetail.List(i, 2) = r.Cells(1, "C")
        lstDetail.List(i, 3) = r.Cells(1, "E")
        lstDetail.List(i, 4) = r.Cells(1, "F")
        lstDetail.List(i, 5) = r.Address 'Test Column
    Next

End Sub

如何使用searchbox向VBA列表框添加更多列

1 个答案: