мои извенения. я не знаю, о чем я думал. полностью пропустил частичную часть матча. опубликованный Dy.Lee выглядит очень хорошо.

я есть этот код, который в основном фильтрует значения в списке, как значение изменяется в текстовом поле на пользовательской форме в Excel

Private Sub TextBox1_Change()

Dim sht As Worksheet
Dim rng1 As Range
Set sht = Sheet5
Set rng1 = sht.Range("F2:F" & sht.Range("F" & sht.Rows.Count).End(xlUp).Row)

ListBox2.ColumnCount = 7

'=====
Dim i As Long
Dim arrList As Variant

Me.ListBox2.Clear
If sht.Range("F" & sht.Rows.Count).End(xlUp).Row > 1 Then
    arrList = sht.Range("F2:L" & sht.Range("F" & sht.Rows.Count).End(xlUp).Row).Value2
    For i = LBound(arrList) To UBound(arrList)
        If InStr(1, arrList(i, 1), Trim(Me.TextBox1.Value), vbTextCompare) Then
            liste = ListBox2.ListCount
            Me.ListBox2.AddItem
            Me.ListBox2.List(liste, 0) = arrList(i, 1)
            Me.ListBox2.List(liste, 1) = arrList(i, 2)
            Me.ListBox2.List(liste, 2) = arrList(i, 3)
            Me.ListBox2.List(liste, 3) = arrList(i, 4)
            Me.ListBox2.List(liste, 4) = arrList(i, 5)
            Me.ListBox2.List(liste, 5) = arrList(i, 6)
            Me.ListBox2.List(liste, 6) = arrList(i, 7)

        End If
    Next i
End If

If Me.ListBox2.ListCount = 1 Then Me.ListBox2.Selected(0) = True

End Sub

Это работает отлично, за исключением случаев, когда я меняю значение с чего-то на пустое значение, то есть пустое время занимает около 4-5 секунд, чтобы завершить заполнение около 8k строк * 7 столбцов данных из листа в списке, что нежелательно. Есть ли способ ускорить процесс?

 Rohan27 окт. 2017 г., 23:14
@ DavidG.manually. Это подпункт события изменения текстового поля. Я ввожу какое-то значение, а затем удаляю его, используя backspace.
 Patrick Lepelletier28 окт. 2017 г., 10:41
положивTrim(Me.TextBox1.Value) в переменной строке, вам не нужно будет рассчитывать каждый цикл
 user875374627 окт. 2017 г., 23:05
Привет, как вы меняете значение на ничто? Я не могу найти эту строку в вашем коде.
 T.M.29 окт. 2017 г., 20:21
@Rohan, я добавил высокоскоростной метод для заполнения вашего списка полными данными одной строкой кода и добавил идеи для дальнейшего улучшения.

Ответы на вопрос(3)

Решение Вопроса

иву.

Private Sub TextBox1_Change()

Dim sht As Worksheet
Dim rng1 As Range
Dim vR() As Variant

Set sht = Sheet5
Set rng1 = sht.Range("F2:F" & sht.Range("F" & sht.Rows.Count).End(xlUp).Row)

ListBox2.ColumnCount = 7

'=====
Dim i As Long
Dim arrList As Variant

Me.ListBox2.Clear
If sht.Range("F" & sht.Rows.Count).End(xlUp).Row > 1 Then
    arrList = sht.Range("F2:L" & sht.Range("F" & sht.Rows.Count).End(xlUp).Row).Value2
    For i = LBound(arrList) To UBound(arrList)
        If InStr(1, arrList(i, 1), Trim(Me.TextBox1.Value), vbTextCompare) Then
            n = n + 1
            ReDim Preserve vR(1 To 7, 1 To n)
            For j = 1 To 7
                vR(j, n) = arrList(i, j)
            next j
        End If
    Next
     Me.ListBox2.List = WorksheetFunction.Transpose(vR)
End If

If Me.ListBox2.ListCount = 1 Then Me.ListBox2.Selected(0) = True

End Sub
 Patrick Lepelletier28 окт. 2017 г., 10:44
next j неnex j
 Dy.Lee05 нояб. 2017 г., 02:03
@ Т.М., я был немного неточным. если n = 1, то Me.ListBox2.column = vR
 Dy.Lee28 окт. 2017 г., 11:28
@PatrickLepelletier, спасибо за комментарий. Я исправил опечатки.
 Patrick Lepelletier28 окт. 2017 г., 10:53
вместоredim preserve в каждом цикле вы можете изменить его в начале цикла, того же размера, что и arrList (максимальный размер), и послеNext i, ты переделываешь это снова,1 to n
 Dy.Lee28 окт. 2017 г., 11:32
@PatrickLepelletier, размер arrList и vR () не совпадают. Поэтому я использовал Redim Preserve.

Как сократить необходимое время практически до нуля

трюк для ускорения заполнения около 8 тысяч строк * 7 столбцов данных из листа в спискене использоватьAddItemкаждый раз, но для установки целого массива в список:

    Me.ListBox2.List = a

после проверки, если строка поискаs пуст по

    If Len(s) = 0 Then                                      

Код

Option Explicit

Private Sub TextBox1_Change()

Dim t       As Double     ' Timer
Dim oSht    As Worksheet
'=====
Dim liste   As Long
Dim i       As Long
Dim j       As Long
Dim n       As Long
Dim s       As String
Dim a       ' data field array, variant! (shorter for arrList)

t = Timer
Set oSht = ThisWorkbook.Worksheets("Test")          ' set worksheet fully qualified reference to memory

ListBox2.ColumnCount = 7                            ' dimension listbox columns

s = Me.TextBox1.Value                               ' get search string
Me.ListBox2.Clear                                   ' clear listbox
n = oSht.Range("F" & oSht.Rows.Count).End(xlUp).Row ' get last row number
If n > 1 Then                                       ' at least 1 line needed
  ' write range to one based 2dim data field array
    a = oSht.Range("F2:L" & n).Value2

    If Len(s) = 0 Then                              ' check if EMPTY string
    '   ====================================
    '   Trick: add complete items all in one
    '   ====================================
        Me.ListBox2.List = a                        ' avoids loop
        Debug.Print "Time needed: " & Format(Timer - t, "0.00 ") & " seconds." & vbNewLine & _
                    "Empty string """": all " & UBound(a) & " items refreshed."
    Else
    ' loop through ONE based 2dim array
      For i = LBound(a) To UBound(a)

        If InStr(1, a(i, 1), Trim(s), vbTextCompare) Then
           Me.ListBox2.AddItem                      ' add new listbox item
         ' enter 7 column values
           For j = 1 To 7                           ' ListBox2.List is ZERO based!!
               Me.ListBox2.List(Me.ListBox2.ListCount - 1, j - 1) = a(i, j)
           Next j
        End If

      Next i
      Debug.Print "Time needed: " & Format(Timer - t, "0.00 ") & " seconds." & vbNewLine & _
                  "Search string """ & s & """:" & Me.ListBox2.ListCount & " items found."

    End If
End If
If Me.ListBox2.ListCount = 1 Then Me.ListBox2.Selected(0) = True
End Sub

Запись

Мое беспокойство былоулучшить скорость послепустой строкой входит. Поэтому я сконцентрировался на этой части и оставил ваш следующий код почти таким же, каким он был, но немного отполировал его, чтобы сделать его более читабельным, и использовал более короткие имена (например,aвместоarrList). Чтобы контролировать это, я добавилTimer, Кстати, я думаю, что вы забыли некоторые объявления переменных.

Идея для дальнейшего улучшения скорости

Если вы хотите ускорить обычный поиск строк, я бы предложил использовать следующие шаги:

использованиерасширенная фильтрация ввременный Рабочий лист,читать содержимое в новый массив полей данных,запишите его обратно в список с помощью описанного метода и(впоследствии удалите временную таблицу).

Конечно, вы найдете правильный код для этого :-)

Дополнительная подсказка

Я рекомендую прочитать "Массивы и диапазоны в VBA" К.Пирсона вhttp://www.cpearson.com/excel/ArraysAndRanges.aspx, Пример работы со списками см. ТакжеExcel VBA - избежать ошибки 1004 при записи UF ListBox Array на лист

Удачи!

================================================== знак равно

Последующее редактирование (см. Предыдущие комментарии от 11 / 4-5)

Этот reedit сочетает в себе не только преимущества ускорения (A) поиска пустой строки (см. Мой собственный ответ выше) с (B) очень быстрым и высоко ценимым подходом Dy Lee (строка поиска не пустая), но и завершает его решение, рассматривая один лайнеры и "нулевые" лайнеры тоже.

В недавно предложенном решении проводится различие между одними вкладышами и другими.

     '' ===========================
      '' B1 get one liners correctly
      '' ===========================
      '  If ii = 1 Then
      '     Me.ListBox2.Column = vR
      '' ===============================================
      '' B2 get others with exception of 'zero' findings
      '' ===============================================
      '  ElseIf ii > 1 Then
      '     Me.ListBox2.List = WorksheetFunction.Transpose(vR) ' not necessary, see below
      '  End If

но может быть заменено только одной строкой кода, так какListBox.Column свойство ретранслирует уже транспонированный массив vR в любом случае правильно в 2dim массив

         Me.ListBox2.Column = vR

тогда какListBox.List собственность сделает двойную работу в этом случае.

Дополнительная подсказка:

Стоит отметить, что заполнение списков черезмассивы полей данных помогает преодолеть ограничение встроенного списка ** 10 столбцов "при использованииAddItem метод.

Обобщенный код

Следующий немного измененный код должен обобщать все пункты и помогать другим пользователям понимать все сделанные улучшения (thx @ Dy.Lee):

Решение Dy Lee усовершенствовано и прокомментировано

Option Explicit
Private Sub TextBox1_Change()
' Note:    based on Dy.Lee's approach including zero and one liners
' Changes: a) allows empty string search by one high speed code line
'          b) writes back one liners correctly via .Column property instead of .List property (cf. comment)
'          c) excludes zero findings to avoid error msg
' declare vars
  Dim t       As Double                          ' Timer
  Dim s       As String                          ' search string
  Dim oSht    As Worksheet                       ' work sheet
  Dim r       As Range
  '=====
  Dim a       As Variant                         ' one based 2-dim data field array
  Dim vR()    As Variant                         ' transposed array
  Dim i       As Long                            ' rows
  Dim j       As Long                            ' columns
  Dim ii      As Long                            ' count findings
  Dim jj      As Long                            ' count listbox columns (.ColumnCount)
  Dim n       As Long                            ' last row
  Dim nn      As Long                            ' findings via filter function
  t = Timer                                      ' stop watch
  s = Me.TextBox3                                ' get search string
  Set oSht = ThisWorkbook.Worksheets("Test")
' get last row number
  n = oSht.Range("F" & oSht.Rows.count).End(xlUp).Row
  if n = 1 then exit sub                 ' avoids later condition

  ListBox2.ColumnCount = 7                       ' (just for information)
  jj = ListBox2.ColumnCount
  ListBox2.Clear                                 ' clear listbox elements

' write range to one based 2dim data field array
  a = oSht.Range("F2:L" & n).Value2

' ========================
' A) EMPTY string findings                ' show all items
' ========================
If Len(s) = 0 Then                               ' check if EMPTY string
  ' ====================================
  ' Trick: add complete items all in one
  ' ====================================
    Me.ListBox2.List = a                         ' avoid loops, double speed
' ========================
' B) other actual findings
' ========================
Else                         ' 

   ' write results to redimmed and transposed array
     For i = LBound(a) To UBound(a)
         If InStr(1, a(i, 1), Trim(s), vbTextCompare) Then
                ii = ii + 1
                ReDim Preserve vR(1 To jj, 1 To ii)
                For j = 1 To jj
                    vR(j, ii) = a(i, j)
                Next j
         End If
      Next
    ' ==============================
    ' B1-B2) get any actual findings (retransposes both cases correctly to 2dim!)
    ' ==============================
      If ii >=1 then ListBox2.Column = vR ' exclude "zero" lines
End If

If Me.ListBox2.ListCount = 1 Then Me.ListBox2.Selected(0) = True

' time needed
  Debug.Print "Time needed: " & Format(Timer - t, "0.00 ") & " seconds." & _
                " - Search string """ & s & """: " & Me.ListBox2.ListCount & " items found."
End Sub
 Dy.Lee05 нояб. 2017 г., 03:45
если n = 1, то Me.ListBox2.Column = vR
 T.M.05 нояб. 2017 г., 11:01
@ Dy.Lee, я сделал обзор, чтобы суммировать все улучшения. Перечитав справку через долгое время, я обнаружил, что с помощью списка.Column имущество даже не выделяет, чтобы отличить один вкладыш (.Column) и выше выводы (.List), поскольку массив vR уже транспонирован ReDim, и оба метода транспонируются обратно правильно. Так что я тоже узнал. Дополнительное примечание: я использовал другую переменную Nameii вместо вашегоn.

использовать свойство rowource

Option Explicit

Private Sub TextBox1_Change()

    Dim sht As Worksheet
    Set sht = Sheet1

    Dim dataEnd as long
    dataEnd = sht.Range("F" & sht.Rows.Count).End(xlUp).Row

    Dim rng1 As Range
    Set rng1 = sht.Range("F2:F" & dataEnd)

    ListBox2.ColumnCount = 7
    ListBox2.ColumnWidths = "30 pt;30 pt;30 pt;30 pt;30 pt;30 pt;30 pt"
    '=====
    Dim i As Long
    Dim listData As Range

    ' Me.ListBox2.Clear
    If dataEnd > 1 Then
        Set listData = sht.Range("F2:L" & dataEnd)

        Me.ListBox2.RowSource = Sheet2.Name & "!" & listData.Address  ' this fills the listbox

    End If

    If Me.ListBox2.ListCount = 1 Then Me.ListBox2.Selected(0) = True

End Sub
 Patrick Lepelletier28 окт. 2017 г., 10:49
если вы используете его как диапазон, то переименуйте его в rangeList или что-то еще. ArrList слишком запутан, когда кто-то другой должен читать ваш код.
 Rohan28 окт. 2017 г., 06:31
Где в коде проверяется частичное совпадение строки, введенной в текстовое поле?
 jsotola29 окт. 2017 г., 06:21
мои извенения. я не знаю, о чем я думал. полностью пропустил частичную часть матча. опубликованный Dy.Lee выглядит очень хорошо.

Ваш ответ на вопрос