Autofiltro, combo y listbox

19/06/2006 - 04:13 por klomkbock | Informe spam
Hola de nuevo,

Posiblemente sea abusar mucho el hacer dos consultas seguidas, pero estoy
enfrascado en una aplicacion que empieza a eternizarse, y uno de los
principales flecos que me quedan es el de la velocidad. Asi que he
decidido arriesgame a una incorreccion. Espero que no moleste a nadie, y
si es asi le pido disculpas de antemano.

Tengo un formulario con un combobox que se rellena con registros unicos de
un campo elegido en funcion de un optionbutton(entre seis optb), y que a
la vez rellena un litbox con las coincidencias segun se pulsa el teclado
en el combo. Funciona aceptablemente bien con pocos registros, pero cuando
el nº es grande (pej: 10.000), le cuesta bastante. He intentado usar
autofiltros en funcion del criterio elegido en el combo para que la
busqueda sea con menos registros, pero a pesar de probar numerosas formas
(casi todas ellas sacadas del foro) no lo consigo. Posiblemente se deba a
que no los aplico en el evento/momento adecuado (aparte de que no acabo de
comprender su sintaxis), he probado en change del combo, pero posiblemente
entre en "conflicto" con los "pulsos" (es un suponer) del teclado y por
eso no da resultado.

A continuacion expongo los codigos que creo intervienen en el proceso. Son
unos cuantos, pero quizas sea la unica forma de mostrarlo en condiciones.
Por cierto, una buena parte estan desarrollados a partir de codigos de
respuestas de expertos ( HM, KL, ..) en el foro. Muchas gracias de nuevo,
y espero no haberoslos desgraciado mucho.

-Codigos

'' He añadido la eñe, el punto y la coma (creo)
Private Sub cmbCriterio_KeyDown(ByVal KeyCode As MSForms _
.ReturnInteger, ByVal Shift As Integer)
Application.ScreenUpdating = False
Select Case KeyCode
Case vbKeyReturn, vbKeyEscape
SendKeys "{Esc}"
Case vbKeyBack
If Pulsos > 0 Then Pulsos = Pulsos - 1
Case 32, 46, 48 To 57, 65 To 90, 97 To 122, 241
Pulsos = Pulsos + 1
End Select
Application.ScreenUpdating = True
End Sub



Private Sub cmbCriterio_Change()
With lstSeleccionar: Num = 0: .Clear: .ColumnCount = 4
LlenarLista
txtNroLibros = .ListCount: End With
End Sub



Private Sub optTitulo_Click()
lstSeleccionar.Clear: Num = 0
Pulsos = 0: Patron = ""
strCombo = "b2:b": rngOrd = "b"
RellenarCombo
cmbCriterio.SetFocus
End Sub




Private Sub optAutor_Click()
lstSeleccionar.Clear: Num = 0
Pulsos = 0: Patron = ""
strCombo = "c2:c": rngOrd = "c"
RellenarCombo
cmbCriterio.SetFocus
End Sub

-

Private Sub RellenarCombo()
Dim Unicos As New Collection
Application.ScreenUpdating = False
With Worksheets("Listado")
Y = .Range("a65536").End(xlUp).Row

''' strCombo y rngOrd voy a cambiarlos a los optButton directamente:
'If optTitulo = True Then
' strCombo = "b2:b": rngOrd = "b"
'ElseIf optAutor = True Then
' strCombo = "c2:c": rngOrd = "d"
'ElseIf optGenero = True Then
' strCombo = "d2:d": rngOrd = "e"
'ElseIf optTema = True Then
' strCombo = "e2:e": rngOrd = "f"
'ElseIf optPais = True Then
' strCombo = "f2:f": rngOrd = "g"
'ElseIf optHermano = True Then
' strCombo = "g2:g": rngOrd = "h"
'ElseIf optApellido = True Then
' strCombo = "l2:l": rngOrd = "l"
'End If
If chkOrdenar = True Then _
.Range(.Range("a1"), .Range("l" & Y)).Sort _
key1:=.Range(rngOrd & "1"), header:=xlYes
Set rngCombo = .Range(strCombo & Y)
On Error Resume Next
For Each Celda In rngCombo
If Trim(Celda) <> "" Then Unicos.Add Celda, CStr(Celda)
Next
With cmbCriterio: .Clear: .ListIndex = -1: End With
With lstSeleccionar: .Clear: .ListIndex = -1: End With
For Sig = 1 To Unicos.Count
cmbCriterio.AddItem Unicos.Item(Sig)
Next
End With
Set Unicos = Nothing
Application.ScreenUpdating = True
End Sub



Private Sub LlenarLista()
Dim filH As Long, ac As Single
If Not Pulsos > 0 Then Exit Sub
Patron = Trim(LCase(Left(cmbCriterio, Pulsos)))
Application.ScreenUpdating = False
With Worksheets("Listado")
.Range(.Range("a1"), .Range("l" & Y)).Sort _
key1:=.Range("a1"), header:=xlYes
End With
For Each Celda In rngCombo
With Celda
If Trim(LCase(Left(.Value, Pulsos))) = Patron Then
filH = .Row
With lstSeleccionar
.TextColumn = 1
.AddItem
For ac = 0 To .ColumnCount - 1
.List(Num, ac) = Range("a" & filH & ":d" & filH)(ac + 1).Value
Next ac
Num = Num + 1
End With
txtNroLibros = lstSeleccionar.ListCount
End If
End With
Next
Application.ScreenUpdating = True
End Sub

En cualquier caso muchas gracias
Un saludo y hasta pronto
Ivan

Preguntas similare

Leer las respuestas

#6 klomkbock
22/06/2006 - 03:08 | Informe spam
Hola Hector Miguel, aqui estoy otra vez dispuesto a agotarte/os con mi
ignorancia.

He estado haciendo pruebas con advancedfilter, pero siempre acabo llegando
al mismo resultado: el nombre no existe o no esta permitido (miento, en
alguna ocasion me ha dicho que un objeto no era un objeto, cuando un
milimetro antes en el codigo parecia comportarse como tal).

Al final he decidido empezar un poco mas abajo, por los filtros normales,
a ver si estos me hacen comprender las manias del avanzado.

Con estos parece que he conseguido algo mas. He conseguido copiar los
rangos y llenar el combo. Pero como no consigo evitar los duplicados he
decidido (de momento) seguir con el codigo inicial.

Tambien he conseguido filtrar la hoja segun los pulsos del teclado(mas o
menos), pero lo que no consigo es rellenar el listbox. Me da la impresion
de que el problema esta en el redimensionado del rango (¿con resice?)
"visual". No se muy bien como aplicarlo.

Si no te importa echarle un vistazo y decirme lo que ves, te lo agradezco.

Vuelvo a poner los codigos que mas o menos intervienen.

Private Sub cmbCriterio_Change()
With lstSeleccionar: .ColumnCount = 4: Num = 0: .Clear: LlenarLista
txtNroLibros = .ListCount: End With
End Sub

Private Sub optPais_Click()
lstSeleccionar.Clear: Num = 0
Pulsos = 0: Patron = ""
strCombo = "f2:f": rngOrd = "f": nroField = 6
With cmbCriterio: .Text = "": .Clear: End With
RellenarCombo
cmbCriterio.SetFocus
End Sub

'''Este proc. RellenarCombo funciona quitandole un apostrofe pero no evita
los repetidos. Sigo usando el original con la coleccion. Con dos comillas
esta uno de los ultimos intentos con AdvancedFilter:

'Private Sub RellenarCombo()
' Application.ScreenUpdating = False
' With Worksheets("Listado")
' Y = .Range("a65536").End(xlUp).Row
' If chkOrdenar = True Then _
' .Range(.Range("a1"), .Range("l" & Y)).Sort _
' key1:=.Range(rngOrd & "1"), header:=xlYes
' Set rngCombo = .Range(strCombo & Y)
' .UsedRange.AutoFilter
' If .AutoFilterMode Then
' .Range("a1").CurrentRegion.AutoFilter Field:=nroField, _
' Criteria1:="<>"
'' .Range("a1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
'' CriteriaRange:=rngCombo, _
'' CopyToRange:=Worksheets("Oculta").Range("a1"), _
'' Unique:=True
' rngCombo.SpecialCells(xlCellTypeVisible) _
' .Copy Worksheets("Oculta").Range("a1")
'' End With
' With Worksheets("Oculta")
' If .[a2].Value = "" Then Exit Sub
' For Each Celda In .Range(.[a2], .[a65536].End(xlUp))
' cmbCriterio.AddItem Celda.Value
' Next
' .Range(.[a1], .[a65536].End(xlUp)).ClearContents
' End With
' End If
' .AutoFilterMode = False
' End With
' Application.ScreenUpdating = True
'End Sub

'''Este proc. filtra el listado sobre la marcha (+o-) segun los pulsos del
teclado, pero no rellena el listbox y tampoco da error, Como comentario
esta un intento de resice, pero me da error y me dice que se esperaba "=".

Private Sub LlenarLista()
Dim filH As Long, ac As Single, rngVisible As Range
If Not Pulsos > 0 Then Exit Sub
Patron = Trim(LCase(Left(cmbCriterio, Pulsos)))
Application.ScreenUpdating = False
With Worksheets("Listado")
.UsedRange.AutoFilter
If .AutoFilterMode Then
.Range("a1").CurrentRegion.AutoFilter Field:=nroField, _
Criteria1:=Patron & "*"
With .UsedRange.Cells.SpecialCells(xlCellTypeVisible)
If .Rows.Count < 1 Then Exit Sub
'
.offset(0,0).Resize(.cells(1,1),.cells(.Rows.Count,.columns.Count))
For filH = 1 To .Rows.Count
Set Celda = .Cells(filH, nroField)
If Trim(LCase(Left(Celda.Value, Pulsos))) = Patron Then
With lstSeleccionar
.AddItem
For ac = 0 To .ColumnCount - 1
.List(Num, ac) = Celda _
.Offset(0, -(nroField - 1))(ac + 1).Value
Next ac
Num = Num + 1
End With
End If
Next
End With
End If
End With
Application.ScreenUpdating = True
End Sub

Bueno, si puedes ayudarme te lo agradezco.

En cualquier caso muchas gracias
Ivan
#7 Héctor Miguel
22/06/2006 - 04:28 | Informe spam
hola, Ivan !

Mostrar la cita
1) en el ultimo procedimiento que expones -> Private Sub LlenarLista() solo te hace falta 'agregar' al elemento [Celda]
justo en la instruccion '.AddItem' -> .AddItem Celda
-> dicho sea 'de paso'... me ha perdido el siguiente bucle For...Next posterior a tu '.AddItem' :))
aparte de que no estarias eliminando los duplicados... no alcanzo a ver cual es 'su objetivo' -?-

2) el uso de los filtros avanzados [que es mas 'avanzado' que los autofiltros] requiere 'dimensiones' distintas [a los autofiltros] p.e.
para el argumento 'CriteriaRange'... SOLO se necesitan [en este caso] DOS filas ['arriba' los titulos y 'abajo' los criterios] ;)
y en el codigo estas 'asignando' [casi] toda una columna :-(( [me explico]...
-> estas usando lo siguiente: -> CriteriaRange:=rngCombo [donde]...rngCombo esta compuesto de la siguiente manera
a) Set rngCombo = .Range(strCombo & Y)
b) strCombo = "f2:f"
c) Y = .Range("a65536").End(xlUp).Row
-> 'esto' es el rango al que aplicas -> autofiltros -> SIN la celda de los encabezados [supongo 'F1'] -?-
-> se necesitaria [para una sola columna o campo al que se aplicara el criterio]...
a) el titulo IGUAL al de la base de datos 'original'
[p.e. en H1 -> Pais]
b) el criterio que se iria 'depositando' segun va cambiando el combo que 'comanda' las acciones de eleccion del usuario
[p.e. en H2 -> lo que va cambiando en el cmbCriterio ?]
c) la asignacion quedaria +/- asi: -> CriteriaRange:=Worksheets("hoja donde vas actualizando el").Range("h1:h2")

si cualquier duda... comentas ?
saludos,
hector.

__ la consulta original __
Mostrar la cita
#8 klomkbock
22/06/2006 - 19:56 | Informe spam
Hola Hector Miguel, lo primero gracias de nuevo por tu ayuda/instruccion.
Es impagable.

justo en la instruccion '.AddItem' -> .AddItem Celda
Mostrar la cita
posterior a tu '.AddItem' :))
Mostrar la cita
ver cual es 'su objetivo' -?-

Me temo que me habia dejado demasiadas cosas en el "tintero", o que quizas
no me he sabido explicar.

La idea es rellenar un listBox (lstSeleccionar) de 4 columnas y seleccion
multiple con los 4 primeros campos de los registros que coincidan (que
vayan/sigan coincidiendo) con lo que se va escribiendo en un comboBox
(cmbCriterio), para que luego el usuario pueda seleccionar los que desee.

El combo se rellena previamente con todos los datos no repetidos del campo
elegido segun unos optionButtons (que puede no ser uno de los que se van a
introducir en el listbox).

El bucle for next que mencionas es para rellenar el lstSelecionar, aunque
no estoy seguro de si es mas rapido que rellenarlo columna a columna:
.AddItem
.List(num,o)=Range(filh,1).Value
.List(num,1)=Range(filh,2).Value => etc..

El combo lo sigo rellenando mediante una coleccion (dada mi ineptitud de
cara a los filtros avanzados, aunque tendre que leer con calma tus
consejos y echarle un poco de tiempo). ¿Quizas al tratarse de un solo
campo esto no ralentice tanto?

Lo que si (creo que) ralentiza mucho es el llenado del listBox. Por eso, y
tras leer mas de una respuesta del foro (tuyas y de KL generalmente),
pense que quizas el uso de autofiltros, al ir trabajando solo con los
registros necesarios, agilizaria un poco la ejecucion. El problema es que
al no haber trabajado nunca con autofiltros (por codigo) de ningun tipo
(los intente abordar una vez tras un consejo tuyo, pero acabe
desistiendo), no acabo de tener muy claro como trabajar con los datos
filtrados.

Aun asi, parece que gracias a vosotros poco a poco voy viendo por donde
van (muy poco a poco) los tiros. Parece bastante importante la visibilidad
del rango y su redimensionamiento. Habra que empeñarse un poco.

Y despues de este rollo, al grano.

Al fin he conseguido rellenar el listbox con los datos filtardos
(autofiltro normal) y copiados a la hoja "oculta" (por cierto, para
trabajar con ella ¿tiene que estar visible, o se pueden cargar y descargar
los datos estando oculta de verdad?). Ahora el problema me viene
probablemente de otro lado: aunque inicialmente el listbox va haciendo
caso a los "pulsos" del teclado, poco a poco va decayendo su obediencia,
hasta llegar a un punto en que no hace ni puñetero caso y me dice que no
hay ninguna coicidencia, cuando yo se que hay unas cuantas. Este problema
me viene de hace tiempo, pero creia haberlo resuelto asignando a la
variable "Pulsos" - un inciso: el codigo es tuyo, o al menos expuesto por
ti en una consulta de alguien hace tiempo, yo solo le he añadido la Ñ y el
punto, y la coma- el valor 0 al cambiar de criterio, y a "Patron" una
cadena vacia. Ahora ha vuelto a aparecer. Supongo que sera mirar despacito
todas las novedades.

Expongo el codigo resultante, que de momento lo he puesto todo (lo
referido al listBox, el combo se rellena en los optButtons) en
cmbCriterio_Change:

Disculpa por este rollo y si puedes ehchar un vistazo al codigo y decirme
tu opinion y como lo puedo adelgazar/hacer mas eficiente, te lo agradezco.

Un saludo y hasta pronto
Ivan

Codigo para rellenar el lstSeleccionar

Private Sub cmbCriterio_Change()
If Not Pulsos > 0 Then Exit Sub
Patron = Trim(LCase(Left(cmbCriterio, Pulsos)))
Dim filH As Long, ac As Single, rngVisible As Range
With lstSeleccionar: .Clear: .ColumnCount = 4: End With
Num = 0
Application.ScreenUpdating = False
lstSeleccionar.Clear
With Worksheets("Listado")
.UsedRange.AutoFilter
If .AutoFilterMode Then
.Range("a1").CurrentRegion.AutoFilter _
Field:=nroField, _
Criteria1:=Patron & "*"
With .AutoFilter.Range
If .Rows.Count > 1 Then
On Error Resume Next
.Resize(.Rows.Count - 1).Offset(1) _
.SpecialCells(xlCellTypeVisible) _
.Copy Worksheets("oculta").Range("a1")
With Worksheets("oculta")
For Each Celda In .Range(.[a1], .[a65536].End(xlUp))
With Celda
'' VARIAS PRUEBAS como comentario:
'' If .Offset(0, nroField - 1).Value = Patron & "*" Then
'' If Trim(LCase(Left(.Offset(0, nroField - 1) _
'' .Value, Pulsos))) = Patron Then
If Trim(LCase(Left(.Offset(0, nroField - 1).Value,
Pulsos))) _
= Trim(LCase(Left(cmbCriterio, Pulsos))) Then
filH = .Row
With lstSeleccionar
.AddItem
For ac = 0 To .ColumnCount - 1
.List(Num, ac) = Worksheets("Oculta") _
.Range("a" & filH & ":d" & filH)(ac + 1).Value
Next ac
Num = Num + 1
End With
End If
End With
Next
.UsedRange.ClearContents
End With
End If
End With
End If
.AutoFilterMode = False
End With
lstSeleccionar.ListIndex = -1
txtNroLibros = lstSeleccionar.ListCount
Application.ScreenUpdating = True
End Sub

PD: el codigo de los pulsos esta en el primer mensaje del hilo.
Ads by Google
Search Busqueda sugerida