A vueltas con los filtros avanzados

Hola a todos. Espero que los que esteis por otras latitudes no os esteis
derritiendo como los que andamos por estas, las hispanicas.

Aqui vuelvo de nuevo a abusar de vuestra generosidad.

Llevaba tiempo dandole vueltas a los filtros avanzados para rellenar un
combobox con los registros unicos de un campo variable(puede variar la
longitud del campo y el campo mismo). Al fin lo he conseguido.

El problema es que el motivo de usar los filtros era ganarle en velocidad
al proceso, que hasta ahora realizaba mediante un objeto collection,
cuando se trata de trabajar con varios miles de registros.

Por lo que se(de muy buena fuente en estas lides), el uso de filtros hace
mas rapida la ejecucion que el de colecciones, sin embargo, algo debo de
estar haciendo mal, pues de momento, y tras probar unas cuantas
posibilidades, el uso del objeto collection es bastante mas rapido que los
filtros.

Para 5000 registros, con filtro avanzado tarda entre 6 y 10 segundos,
mientras que con collection tarda un maximo de 2 segundos(si estos tiempos
fueran asi para hasta 20000 registros me podrian valer, pero me seguiria
quedando la espina de los filtros avanzados y de en que estoy fallando)

Al final expongo los codigos en ambos casos. Con los filtros expongo 3,
que tardan practicamente igual, pero antes explico su entorno brevemente??:

En los codigos intervienen:

=>a) tres hojas(en unos intervienen dos y tres en otros):

.-Hoja1= "Listado": contiene la lista con los datos. Para las pruebas
actuales 5000 registros. El unico campo que no puede tener registros
repetidos es el 1º(columna A) y, a partir del 5º(columna E), puede
contener registros vacios.
.-Hoja2= "Matrices": contiene listas para rellenar matrices o variables.
La que interviene en los codigos es la columna A que contiene un listado
con todas las letras de la A a la Z, que se corresponden con las columnas
de Listado (26 en total)
.-Hoja3= "Oculta": se usa para pegar los datos filtrados y pasarlos al
combo de destino.

=>b) dos combobox (que interesen al caso) de un formulario:

.-ComboBox1= "cmbElegir": contiene los titulos de los 26 campos de
"Listado" (rango "a1:z1"). Se cargan al inicializarse el formulario.
.-ComboBox2= "cmbCriterio": se rellena con los registros no repetidos del
campo elegido en "cmbElegir"(cmbElegir_Change).

==>> Este es el codigo con collection:

Private Sub cmbElegir_Change()
Dim rngListado As Range, xList As Long
Dim ListaUnicos As New Collection
Application.ScreenUpdating = False
With cmbElegir
If .Value = .BoundValue Then Exit Sub
cmbCriterio.Clear: lstSeleccionar.Clear
If .ListIndex < 0 Then Exit Sub Else nL = .ListIndex + 1
End With
ltC = Worksheets("Matrices").Cells(nL, 1)
With Worksheets("Listado")
If .AutoFilterMode Then .AutoFilterMode = False
fF = .[a65536].End(xlUp).Row
.Range("a1:z" & fF).Sort _
key1:=.Range(ltC & "1"), _
header:=xlYes
For Each rngListado In .Range(ltC & "2:" & ltC & fF)
On Error Resume Next
If Trim(rngListado) <> "" Then _
ListaUnicos.Add rngListado, CStr(rngListado)
On Error GoTo 0
Next
End With
For xList = 1 To ListaUnicos.Count
cmbCriterio.AddItem ListaUnicos(xList)
Next
Set ListaUnicos = Nothing
Application.ScreenUpdating = True
End Sub

==>> y estos con advanced filter

->1ªprueba

Private Sub cmbElegir_Change()
''Se filtra bien, pero mas bien lento _
'''(de 7 a 10 sg con 5000 filas)
Application.ScreenUpdating = False
With cmbElegir
If .Value = .BoundValue Then Exit Sub
cmbCriterio.Clear: lstSeleccionar.Clear
If .ListIndex < 0 Then Exit Sub Else nL = .ListIndex + 1
End With
ltC = Worksheets("Matrices").Cells(nL, 1)
With Worksheets("Oculta")
.UsedRange.EntireRow.Delete
With Worksheets("Listado")
If .AutoFilterMode Then .AutoFilterMode = False
fF = .[a65536].End(xlUp).Row
.Range("a1:z" & fF).Sort _
key1:=.Range(ltC & "1"), _
header:=xlYes
.Range(ltC & "1:" & ltC & fF).AdvancedFilter _
criteriarange:=.Range(ltC & "1:" & ltC & fF), _
Action:=xlFilterCopy, _
copytorange:=Worksheets("Oculta").Range("a1"), _
unique:=True
End With
fFo = .Range("a65536").End(xlUp).Row
If fFo < 2 Then Exit Sub
cmbCriterio.List = .Range("a2:a" & fFo).Value
End With
Application.ScreenUpdating = True
End Sub

->2ªprueba (quizas ligeramente mas rapido que el anterior pero no estoy seguro

Private Sub cmbElegir_Change()
Application.ScreenUpdating = False
With cmbElegir
If .Value = .BoundValue Then Exit Sub
cmbCriterio.Clear: lstSeleccionar.Clear
If .ListIndex < 0 Then Exit Sub Else nL = .ListIndex + 1
End With
With Worksheets("Oculta")
.UsedRange.EntireRow.Delete
With Worksheets("Listado")
If .AutoFilterMode Then .AutoFilterMode = False
fF = .[a65536].End(xlUp).Row
.Range("a1:z" & fF).Sort _
key1:=.Cells(1, nL), _
header:=xlYes
.Range(.Cells(1, nL), .Cells(fF, nL)).AdvancedFilter _
criteriarange:=.Range(.Cells(1, nL), .Cells(fF, nL)), _
Action:=xlFilterCopy, _
copytorange:=Worksheets("Oculta").Range("a1"), _
unique:=True
End With
fFo = .Range("a65536").End(xlUp).Row
If fFo < 2 Then Exit Sub
cmbCriterio.List = .Range("a2:a" & fFo).Value
End With
Application.ScreenUpdating = True
End Sub

->3ªprueba (como la 1ª pero usando algunas variables mas, tarda igual)

Private Sub cmbElegir_Change()
''Prueba con variables range y variant para ver si agiliza
'''pero sigue mas o menos igual
Dim rngListado As Range, rngFiltrado
Application.ScreenUpdating = False
With cmbElegir
' If .Value = .BoundValue Then Exit Sub
cmbCriterio.Clear: lstSeleccionar.Clear
If .ListIndex < 0 Then Exit Sub Else nL = .ListIndex + 1
End With
ltC = Worksheets("Matrices").Cells(nL, 1)
With Worksheets("Oculta")
.UsedRange.EntireRow.Delete
With Worksheets("Listado")
If .AutoFilterMode Then .AutoFilterMode = False
fF = .[a65536].End(xlUp).Row
.Range("a1:z" & fF).Sort _
key1:=.Range(ltC & "1"), _
header:=xlYes
Set rngListado = .Range(ltC & "1:" & ltC & fF)
rngListado.AdvancedFilter _
criteriarange:=rngListado, _
Action:=xlFilterCopy, _
copytorange:=Worksheets("Oculta").Range("a1"), _
unique:=True
End With
fFo = .Range("a65536").End(xlUp).Row
If fFo < 2 Then Exit Sub
rngFiltrado = .Range("a2:a" & fFo).Value
cmbCriterio.List = rngFiltrado
End With
Application.ScreenUpdating = True
End Sub

Bueno, como siempre me ha salido otro tomo.

Si podeis echarme una mano os lo agradezco.

En cualquier caso, un saludo y hasta pronto.
Ivan