descargar mas rapido seleccion multiple en listbox

hola a todos

tengo un formulario con un listbox con 4 columnas y seleccion multiple,
que se carga con los registros de una hoja ("Oculta"), que a su vez se
carga con los de otra ("Listado") filtrados por lo escrito en un
combo.

Un commandbutton (cmdActualizarFavoritos) permite cargar los registros
seleccionados (que no esten ya) en el listbox (lstSeleccionar) en otra
hoja ("Favoritos").

a su vez otro boton (cmdSeleccionarTodos) hace lo que su nombre indica,
seleccionar todos los registros del listbox, que, aunque serian muy
extraño, podrian llegar a ser hasta 10000. En realidad lo normal es
que sean bastantes menos, pues para algo esta el 'filtro'.

en mis pruebas el maximo que se carga tras escribir la primera letra en
el combo, ronda los 4500

Desde aqui el usuario tiene varias opciones, pero si selecciona todos
cuando la cantidad es muy alta y los añade a "Favoritos", viene a
tardar en torno a los 15 segundos (para 4400), tiempo que, aunque no es
excesivo para algo que sera muy raro que ocurra (una seleccion tan
amplia), y que incluso se puede avisar en estas ocasiones, si me
gustaria saber de que forma se podria disminuir.

he pensado en los filtros avanzados o en los autofiltros, pero no se
como los podria utilizar en esta ocasion, compatibilizando a la vez la
busqueda de elementos seleccionados en el listbox y de no repetidos en
"Favoritos"

de momento, y tras bastantes pruebas, me he decantado por esta opcion,
que es la que me ha dado el mejor tiempo, aunque tendre que unirla a
otra que es mucho mas rapida cuando los registros son pocos y que
supongo que tendre que condicionar al nº de registros seleccionados

Private Sub cmdActualizarFavoritos_Click()
Dim nSel As Long, CeldaO As Range, tCol As Long, tcol2 As Long
Dim tarda, x As Long
''pasa los libros seleccionados en lstSeleccionar a_
''la hoja "Favoritos"
tarda = Timer * 1000
With lstSeleccionar
tCol = .TextColumn: .TextColumn = 1
Application.ScreenUpdating = False
For nSel = 0 To .ListCount - 1
If .Selected(nSel) = True Then
On Error Resume Next
If BuscaFilas(CLng(.List(nSel)), "Favoritos") > 0 Then
Worksheets("Oculta").Range("a" & nSel + 2 & ":z" & nSel +
2).Hidden = True
End If
On Error GoTo 0
End If
Next
.TextColumn = tCol
Application.ScreenUpdating = True
End With
With Worksheets("Oculta")
With .UsedRange.Cells.SpecialCells(xlCellTypeVisible)
.Offset(1).Resize(.Rows.Count - 1, .Columns.Count).Copy _
Worksheets("Favoritos").[a65536].End(xlUp).Offset(1, 0)
End With
.Rows.Hidden = False
End With
txtLibrosSeleccionados = 0
tarda = (Timer * 1000) - tarda
Debug.Print "tarda -> " & tarda
End Sub
'*****************************************************
Public Function BuscaFilas(ByVal Valor As Long, _
ByVal nHoja As String) As Long
On Error Resume Next
BuscaFilas = Evaluate("match(" & Valor & "," & nHoja & "!a:a,0)")
On Error GoTo 0
End Function


bueno, si se os ocurre algo sera bien recibido

un saludo y hasta pronto
Ivan