multiselect - userform show vba excel

Cómo acelerar el llenado de los valores de listbox en userform excel

Question

Tengo este código que básicamente filtra los valores en el cuadro de lista a medida que el valor cambia en el cuadro de texto en forma de usuario en 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

Funciona perfectamente, excepto cuando cambio el valor de algo a nada, es decir, en blanco, demora entre 4 y 5 segundos para completar aproximadamente 8k filas * 7 columnas de datos de la hoja en el cuadro de lista, lo que no es deseable. ¿Hay alguna manera de que podamos acelerar las cosas aquí?

Answer 1

Después de poner datos en una nueva matriz, configure listbox por nueva matriz.

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

Answer 2

use la propiedad rowsource

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

Answer 3

Cómo reducir el tiempo necesario a casi cero

El truco para acelerar el llenado de aproximadamente 8k filas * 7 columnas de datos de la hoja en el cuadro de lista no es usar AddItem cada vez, sino establecer una matriz completa en el cuadro de lista:

 Me.ListBox2.List = a

después de verificar si la cadena de búsqueda s está vacía por

 If Len(s) = 0 Then 

Código

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

Nota

Mi preocupación era mejorar la velocidad después de que entra la cuerda vacía . Así que me concentré en esta parte y dejé su código adicional casi como estaba, pero lo pulí un poco para hacerlo más legible y usé nombres más cortos (por ejemplo, a lugar de arrList ). Para controlar eso, agregué un Timer . Por cierto, creo que olvidó algunas declaraciones variables.

Idea para una mayor mejora de la velocidad

Si desea acelerar la búsqueda de cadenas normal, le sugiero usar los siguientes pasos:

• usar el filtrado avanzado en una hoja de trabajo temporal ,
• lea el contenido en una nueva matriz de campo de datos,
• escríbalo de nuevo a la lista mediante el método descrito y
• (elimine la hoja de trabajo temporal después).

Seguro que encontrarás el código correcto para hacerlo :-)

Sugerencia adicional

Recomiendo leer "Arrays and Ranges in VBA" de C.Pearson en http://www.cpearson.com/excel/ArraysAndRanges.aspx . Para ver un ejemplo sobre cómo manipular listboxes, vea también Excel VBA - evite el error 1004 escribiendo UF ListBox Array to Sheet

¡Buena suerte!

=============================================== =

Edición subsiguiente (cf comentarios anteriores al 11 / 4-5)

Esta reedición combina no solo las ventajas de acelerar (A) la búsqueda de cadenas vacías (ver mi propia respuesta anterior) con (B) el enfoque muy rápido y apreciado de Dy Lee (cadena de búsqueda no vacía), sino que completa su solución considerando una revestimientos y revestimientos "cero", también.

La solución recientemente sugerida distingue entre un revestimiento y otros

 '''' ===========================
'''' 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

pero puede ser reemplazado por UNA línea de código solamente, ya que la propiedad ListBox.Column retranspone la matriz vR ya transpuesta en CUALQUIER caso correctamente a una matriz de 2dim

 Me.ListBox2.Column = vR

mientras que la propiedad ListBox.List haría un doble trabajo en este caso.

Sugerencia adicional:

Vale la pena mencionar que AddItem lista mediante matrices de campos de datos ayuda a superar la limitación incorporada de la lista de 10 columnas ** cuando se utiliza el método AddItem .

Código resumido

El siguiente código, ligeramente modificado, debe resumir todos los puntos y ayudar a otros usuarios a comprender todas las mejoras realizadas (thx @ Dy.Lee):

La solución de Dy Lee refinado y comentado

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