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