如何在VBA中为Excel 2016制作搜索条形码?

rqdpfwrv  于 2023-08-08  发布在  其他
关注(0)|答案(1)|浏览(96)

我有一个Excel 2016的代码(这是我工作中使用的应用程序版本),可以根据我在searchBar(ActiveX文本框)中输入的内容过滤表中的结果。
我很想得到帮助,请:

Private Sub TextBox1_Change()
    Dim dataSheet As Worksheet
    Dim dataRange As Range
    Dim searchText As String
    Dim lastRow As Long
    Dim lastColumn As Long
    Dim rngCell As Range
    Dim rngRow As Range
    Dim foundMatch As Boolean

    On Error Resume Next
    Application.EnableEvents = False

    Set dataSheet = ThisWorkbook.Worksheets("Sheet1")

    ' Find the last row and last column of the table
    lastRow = dataSheet.Cells(dataSheet.Rows.Count, 1).End(xlUp).Row
    lastColumn = dataSheet.Cells(1, dataSheet.Columns.Count).End(xlToLeft).Column

    ' Set the data range based on the last row and last column
    Set dataRange = dataSheet.Range("A2", dataSheet.Cells(lastRow, lastColumn))

    ' Get the search text from the TextBox
    searchText = Me.TextBox1.Value ' Use the TextBox name from the Properties window

    ' Clear any previous filters
    dataRange.AutoFilter

    ' Apply the filter only if the search text is not empty
    If Len(searchText) > 0 Then
        ' Loop through each row in the data range
        For Each rngRow In dataRange.Rows
            foundMatch = False ' Reset the flag for each row
            For Each rngCell In rngRow.Cells
                ' Check if the cell value contains the search text
                If InStr(1, rngCell.Value, searchText, vbTextCompare) > 0 Then
                    ' If the cell contains the search text, set the flag and exit the inner loop
                    foundMatch = True
                    Exit For
                End If
            Next rngCell
            ' Hide or unhide the row based on whether a match was found
            rngRow.EntireRow.Hidden = Not foundMatch
        Next rngRow
    Else
        ' If the TextBox is empty, unhide all rows to show the original source data
        dataRange.Rows.Hidden = False
    End If

    Application.EnableEvents = True
End Sub

字符串
我上面写的代码不起作用,我不知道为什么,请帮助我找出问题所在。我的table没有自动过滤。

monwx1rj

monwx1rj1#

我想我明白了为什么它不适合我,它不适合作为ListObject的表。相反,我已经编写了另一段代码,我在这里发布的工作

Private Sub TextBox1_Change()
    
        Dim filterCriteria As String
        Dim ws As Worksheet
        Dim lo As ListObject
        Dim i As Integer
        Dim ConcatFormula As String
    
        Set ws = ThisWorkbook.Sheets("Sheet1")
    
        Set lo = ws.ListObjects("Table1")
    
        ' Prepare CONCATENATE formula
        ConcatFormula = ""
        For i = 1 To lo.ListColumns.Count - 1
            ConcatFormula = ConcatFormula & "RC" & i & ", "" """
            If i <> lo.ListColumns.Count - 1 Then
                ConcatFormula = ConcatFormula & ","
            End If
        Next i
    
        ' Check if helper column exists and create it if not
        On Error Resume Next
        Dim helperCol As ListColumn
        Set helperCol = lo.ListColumns("Helper")
        If helperCol Is Nothing Then
            Set helperCol = lo.ListColumns.Add
            helperCol.Name = "Helper"
            helperCol.DataBodyRange.FormulaR1C1 = "=CONCATENATE(" & ConcatFormula & ")"
        End If
        On Error GoTo 0
    
        ' Hide the helper column
        helperCol.Range.EntireColumn.Hidden = True
    
        If Me.TextBox1.Value = "" Then
            ' Show all data if TextBox is empty
            On Error Resume Next
            lo.AutoFilter.ShowAllData
            On Error GoTo 0
        Else
            ' Define the filter criteria
            filterCriteria = "*" & Me.TextBox1.Value & "*"
            ' Filter the helper column
            lo.Range.AutoFilter Field:=lo.ListColumns.Count, Criteria1:=filterCriteria, Operator:=xlFilterValues
        End If
    End Sub

字符串

相关问题