Текстовое поле поиска 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

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

Но поиск по всем столбцам требует времени, но вот идея

нажмите здесь

Answer 2

Попробуйте этот код ....

  Private Sub TextBox1_Change()
    Me.TextBox1.Text = StrConv(Me.TextBox1.Text, vbProperCase)
    Dim i, x 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)
      For x = 1 To 8
      If Left(Sheet1.Cells(i, x).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
    Next i
End Sub