excel - VBA 搜索文本框和填充列表框

Question

嗨，我有用户表单，我可以在文本框中输入项目的条形码和描述，它会显示结果...但是在我的代码中我只能搜索第一列...我希望工作表中的所有列都可以搜索在文本框中我有 8 列

Private Sub TextBox1_Change()
    Me.TextBox1.text = StrConv(Me.TextBox1.text, vbProperCase)
    Dim i As Long
    Me.ListBox1.Clear
    On Error Resume Next
    For i = 1 To Application.WorksheetFunction.CountA(Sheet1.Range("A:A"))
      a = Len(Me.TextBox1.text)
      If Left(Sheet1.Cells(i, 1).text, a) = Left(Me.TextBox1.text, a) Then
        Me.ListBox1.AddItem Sheet1.Cells(i, 1).Value
        Me.ListBox1.List(ListBox1.ListCount - 1, 1) = Sheet1.Cells(i, 2).Value
        Me.ListBox1.List(ListBox1.ListCount - 1, 2) = Sheet1.Cells(i, 3).Value
        Me.ListBox1.List(ListBox1.ListCount - 1, 3) = Sheet1.Cells(i, 4).Value
        Me.ListBox1.List(ListBox1.ListCount - 1, 4) = Sheet1.Cells(i, 5).Value
        Me.ListBox1.List(ListBox1.ListCount - 1, 5) = Sheet1.Cells(i, 6).Value
        Me.ListBox1.List(ListBox1.ListCount - 1, 6) = Sheet1.Cells(i, 7).Value
        Me.ListBox1.List(ListBox1.ListCount - 1, 7) = Sheet1.Cells(i, 8).Value

      End If
    Next i
End Sub

标签： excelvba

Answer 1

更快地尝试此代码...

Private Sub TextBox1_Change()
    Dim myArray, lr, x, i
    Dim DATA As Worksheet
    Set DATA = Worksheets("Sheet1")
    lr = DATA.Cells(Rows.Count, 1).End(xlUp).Row
    ListBox1.Clear
    If TextBox1.Text = "" Then Exit Sub
    myArray = DATA.Range("A2:H" & lr + 1)
    ReDim y(1 To UBound(myArray) * 8, 1 To 8)
    For i = LBound(myArray) To UBound(myArray)
     a = Len(Me.TextBox1.Text)
     For x = 1 To 8
     If Left(myArray(i, x), a) = Left(TextBox1.Text, a) Then
            rw = rw + 1
            For yy = 1 To 8
                y(rw, yy) = myArray(i, yy)
            Next yy
        End If
        Next
    Next i
    If rw > 0 Then
        ListBox1.List = y()
    End If
End Sub

但是一次搜索所有列需要时间，但这里的想法

点击这里