Excel - OBTENER MAYOR VELOCIDAD EN CARGA DE LISTBOX

Hola a todos.

Tengo un archivo que trabaja con varios ListBox y funciona de la siguiente manera:

Para activar el Userform1 con registros en tres ListBox; Click en celda ("Cuenta") de la hoja Resumen Cart-Cli para activar UserForm1. Después haciendo click en cualquiera de las celdas de Cuenta en la columna (“A5:A57”) cargar de registros al UserForm1(3 ListBox).

Seleccionar doble click un ítem (Vencimiento y Monto) del UserForm1.ListBox Fact1 y buscar en una Hoja Cartola Cli y si lo encuentra llena de registros a otro UserForm2.ListBox Detalle_Factura con condición adicional que correspondan solo a Clase de Documento DF (Cta Cliente-ClaseDoc-Referencia-Monto-Vencimiento-Texto).

Todo eso funciona muy bien, pero el inconveniente que tengo es que la carga de registro al UserForm1 es algo lento ya que mi archivo original contiene un promedio de 300.000 filas y necesito más velocidad.

¿Sera posible la modificación al código que se encuentra en la Hoja Resumen Cart-Cli para que adquiera mayor velocidad en la carga de registros?

Adjunto Archivo.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Cuenta As Variant
Dim WS1 As Worksheet
Dim WS2 As Worksheet
If ActiveCell.FormulaR1C1 = "Cuenta" Then
UserForm1.Show
End If
If Not Intersect(Target, Range("A:A")) Is Nothing And Selection.Count = 1 And _
ActiveCell.FormulaR1C1 <> "Cuenta" Then
Set WS1 = Worksheets("Cartola Cli")
Cuenta = Intersect(Target, Range("A:A"))
filas = WS1.Range("Q1").CurrentRegion.Rows.Count
Mayor_Mes = 0
Menor_Mes = 0
NC_Total = 0
Transacc_Total = 0
UserForm1.Fact1.Clear
UserForm1.NotaCredit.Clear
UserForm1.Transacc.Clear
UserForm1.Menor_Mes.Text = Empty
UserForm1.Mayor_Mes.Text = Empty
UserForm1.NC_Total.Text = Empty
UserForm1.Transacc_Total.Text = Empty
UserForm1.Fact_Total.Text = Empty
UserForm1.Monto_Total.Text = Empty
For I = 2 To filas
If WS1.Cells(I, 17).Value Like Cuenta Then
If UCase(WS1.Cells(I, 3).Value) Like "DF" And WS1.Cells(I, 22).Value <> "Vigente" Then
UserForm1.Fact1.AddItem WS1.Cells(I, 9) 'Vencimiento
UserForm1.Fact1.List(UserForm1.Fact1.ListCount - 1, 1) = WS1.Cells(I, 10) 'Monto
UserForm1.Cuenta.Caption = WS1.Cells(I, 17) 'Cuenta
UserForm1.RazonSocial.Caption = WS1.Cells(I, 20) 'Razon Social
If LCase(WS1.Cells(I, 22).Value) Like "0 a 30" Then
Menor_Mes = Menor_Mes + WS1.Cells(I, 10).Value
ElseIf WS1.Cells(I, 21).Value > 30 Then
Mayor_Mes = Mayor_Mes + WS1.Cells(I, 10).Value
End If
ElseIf UCase(WS1.Cells(I, 3).Value) Like "DN" Then
UserForm1.NotaCredit.AddItem WS1.Cells(I, 9) 'Vencimiento
UserForm1.NotaCredit.List(UserForm1.NotaCredit.ListCount - 1, 1) = WS1.Cells(I, 10) 'Monto
UserForm1.Cuenta.Caption = WS1.Cells(I, 17) 'Cuenta
UserForm1.RazonSocial.Caption = WS1.Cells(I, 20) 'Razon Social
NC_Total = NC_Total + WS1.Cells(I, 10).Value
ElseIf UCase(WS1.Cells(I, 3).Value) Like "DZ" Or UCase(WS1.Cells(I, 3).Value) Like "AB" Or _
UCase(WS1.Cells(I, 3).Value) Like "DD" Then
UserForm1.Transacc.AddItem WS1.Cells(I, 9) 'Vencimiento
UserForm1.Transacc.List(UserForm1.Transacc.ListCount - 1, 1) = WS1.Cells(I, 10) 'Monto
UserForm1.Cuenta.Caption = WS1.Cells(I, 17) 'Cuenta
UserForm1.RazonSocial.Caption = WS1.Cells(I, 20) 'Razon Social
Transacc_Total = Transacc_Total + WS1.Cells(I, 10).Value
End If
End If
UserForm1.Menor_Mes.Text = Menor_Mes
UserForm1.Mayor_Mes.Text = Mayor_Mes
UserForm1.NC_Total.Text = NC_Total
UserForm1.Transacc_Total.Text = Transacc_Total
UserForm1.Fact_Total.Text = Menor_Mes + Mayor_Mes
UserForm1.Monto_Total.Text = Menor_Mes + Mayor_Mes + NC_Total + Transacc_Total
Next I
End If
End Sub

• LitBox1-busque-en-hoja-y-si-lo-encuentra-cargue-el-ListBox2.zip(869,5 KB)

Listo!!

Estimados, ya logré adaptar el código de Matriz en vez del AddItem, ahora el proceso es mas rápido.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim WS1 As Worksheet
Dim WS2 As Worksheet

Dim Cuenta, N°Cuenta As Variant
If ActiveCell.FormulaR1C1 = "Cuenta" Then
UserForm1.Show
End If
With UserForm1.Fact1
If Not Intersect(Target, Range("A:A")) Is Nothing And Selection.Count = 1 And _
ActiveCell.FormulaR1C1 <> "Cuenta" Then
Set WS1 = Worksheets("Cartola Cli")
Cuenta = Intersect(Target, Range("A:A"))

UserForm1.Fact1.Clear
UserForm1.NotaCredit.Clear
UserForm1.Transacc.Clear
UserForm1.Menor_Mes.Text = Empty
UserForm1.Mayor_Mes.Text = Empty
UserForm1.NC_Total.Text = Empty
UserForm1.Transacc_Total.Text = Empty
UserForm1.Fact_Total.Text = Empty
UserForm1.Monto_Total.Text = Empty
N = 0
N1 = 0
N2 = 0
Mayor_Mes = 0
Menor_Mes = 0
NC_Total = 0
Transacc_Total = 0
Fact_Vencida = 0
Estado_Cta = 0
uLTIMAfILA = WS1.Range("A" & Rows.Count).End(xlUp).Row 'Obtiene el valor de la ultima fila con datos
Dim aRR As Variant 'Vector que contendra los datos de la hoja gente
aRR = WS1.Range("A2:W" & uLTIMAfILA).Value2
Dim VR_Fact1() As Variant 'Vector adimensional que se transformara en bidimensional para contener los datos de la busqueda y luego cargarlos en el listbox1
Dim VR_NotaCredit() As Variant 'Vector adimensional que se transformara en bidimensional para contener los datos de la busqueda y luego cargarlos en el listbox1
Dim VR_Transacc() As Variant 'Vector adimensional que se transformara en bidimensional para contener los datos de la busqueda y luego cargarlos en el listbox1
For I = LBound(aRR) To UBound(aRR) 'For, recorre el vector que contiene Datos de la Hoja Cartola Cli desde el registro inicial hasta el registro final
N°Cuenta = aRR(I, 17)
If aRR(I, 3) = "DF" And aRR(I, 22) <> "Vigente" And Cuenta = N°Cuenta Then
N = N + 1
ReDim Preserve VR_Fact1(1 To 2, 1 To N)
For J = 1 To 2
If J = 1 Then
VR_Fact1(J, N) = Format(aRR(I, 9), "d/m/yyyy") 'Vencimiento
UserForm1.Cuenta.Caption = aRR(I, 17)
UserForm1.RazonSocial.Caption = aRR(I, 20)
If LCase(aRR(I, 22)) Like "0 a 30" Then
Menor_Mes = Menor_Mes + aRR(I, 10)
ElseIf aRR(I, 21) > 30 Then
Mayor_Mes = Mayor_Mes + aRR(I, 10)
End If
Else
VR_Fact1(J, N) = Format(aRR(I, 10), "##,##0") 'Monto
End If
Next J
ElseIf aRR(I, 3) = "DN" And Cuenta = N°Cuenta Then
N1 = N1 + 1
ReDim Preserve VR_NotaCredit(1 To 2, 1 To N1)
For J1 = 1 To 2
If J1 = 1 Then
VR_NotaCredit(J1, N1) = Format(aRR(I, 9), "d/m/yyyy") 'Vencimiento
UserForm1.Cuenta.Caption = aRR(I, 17)
UserForm1.RazonSocial.Caption = aRR(I, 20)
NC_Total = NC_Total + Format(aRR(I, 10), "##,##0")
Else
VR_NotaCredit(J1, N1) = Format(aRR(I, 10), "##,##0") 'Monto
End If
Next J1
ElseIf (aRR(I, 3) = "DZ" Or aRR(I, 3) = "DD" Or aRR(I, 3) = "AB") And Cuenta = N°Cuenta Then
N2 = N2 + 1
ReDim Preserve VR_Transacc(1 To 2, 1 To N2)
For J2 = 1 To 2
If J2 = 1 Then
VR_Transacc(J2, N2) = Format(aRR(I, 9), "d/m/yyyy") 'Vencimiento
UserForm1.Cuenta.Caption = aRR(I, 17)
UserForm1.RazonSocial.Caption = aRR(I, 20)
Transacc_Total = Transacc_Total + Format(aRR(I, 10), "##,##0")
Else
VR_Transacc(J2, N2) = Format(aRR(I, 10), "##,##0") 'Monto
End If
Next J2
End If
Next I

'1° Chequeo de la primera parte del texto del combobox
If N = 0 Then
'Caso en que no se encontro ninguna coincidencia
Else
If N = 1 Then
'Caso en que se encontro una sola coincidencia
.Column = VR_Fact1
If Cuenta = 1 Then Cuenta = True
Else
'Caso en que se econtraron mas de una coincidencia
.List = WorksheetFunction.Transpose(VR_Fact1)
If Cuenta = 1 Then Cuenta = True
End If 'If del control n=1
End If 'If del control n=0

'2° Chequeo de la primera parte del texto del combobox
If N1 = 0 Then
'Caso en que no se encontro ninguna coincidencia
Else
If N1 = 1 Then
'Caso en que se encontro una sola coincidencia
UserForm1.NotaCredit.Column = VR_NotaCredit
If Cuenta = 1 Then Cuenta = True
Else
'Caso en que se econtraron mas de una coincidencia
UserForm1.NotaCredit.List = WorksheetFunction.Transpose(VR_NotaCredit)
If Cuenta = 1 Then Cuenta = True
End If 'If del control n=1
End If 'If del control n=0

'3° Chequeo de la primera parte del texto del combobox
If N2 = 0 Then
'Caso en que no se encontro ninguna coincidencia
Else
If N2 = 1 Then
'Caso en que se encontro una sola coincidencia
UserForm1.Transacc.Column = VR_Transacc
If Cuenta = 1 Then Cuenta = True
Else
'Caso en que se econtraron mas de una coincidencia
UserForm1.Transacc.List = WorksheetFunction.Transpose(VR_Transacc)
If Cuenta = 1 Then Cuenta = True
End If 'If del control n=1
End If 'If del control n=0

UserForm1.Total_Reg.Caption = .ListCount
UserForm1.Menor_Mes.Text = Format(Menor_Mes, "##,##0")
UserForm1.Mayor_Mes.Text = Format(Mayor_Mes, "##,##0")
UserForm1.NC_Total.Text = Format(NC_Total, "##,##0")
UserForm1.Transacc_Total.Text = Format(Transacc_Total, "##,##0")
Fact_Vencida = Menor_Mes + Mayor_Mes
UserForm1.Fact_Total.Text = Format(Fact_Vencida, "##,##0")
Estado_Cta = Menor_Mes + Mayor_Mes + NC_Total + Transacc_Total
UserForm1.Monto_Total.Text = Format(Estado_Cta, "##,##0")
End If 'If del control del vencimiento
End With
End Sub

• ListBox1-busca-en-Hoja-con-criterio-de-rango-de-fecha-y-pasa-a-ListBox2.zip(786,2 KB)