Listbox schnell mit vielen Einträgen füllen

Sub Listbox_SQL(mySql As String)
On Error GoTo hell
Dim t
t = Timer
Const pfad As String = "C:\Pfad"          'Access DB PFad
Const myAccessDB As String = "MyAccDB.mdb"                'Access DB Dateiname
Const APPNAME = "mod_Access / Gefilter_laden_SQL"
'ACCESS Tabelle per SQL Kommando filtern und gefilterte laden
Dim cmd As ADODB.Command
Dim con As ADODB.Connection
Dim rs As ADODB.Recordset
Dim spalte As Long
Debug.Print "DIM after: " & Timer - t
Set con = New ADODB.Connection
con.Open ConnectionString:= _
"Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & pfad & "\" & myAccessDB & ";" & _
"Mode=Share Exclusive"
Set cmd = New ADODB.Command
cmd.ActiveConnection = con
Set rs = New ADODB.Recordset
rs.CursorLocation = adUseServer
'rs.Index = "Primarykey"
Debug.Print "SET Con after: " & Timer - t
rs.Open mySql, _
ActiveConnection:=con, _
CursorType:=adOpenStatic, _
LockType:=adLockPessimistic, _
Options:=adCmdTableDirect
Debug.Print "RS after: " & Timer - t
UF_Wahl.ListBox1.Clear
If Not rs.BOF Or rs.EOF Then
rs.MoveFirst
Do While Not rs.EOF
UF_Wahl.ListBox1.AddItem rs.Fields(0).Value
rs.MoveNext
Loop
End If
Debug.Print "Listbox after: " & Timer - t
'*** Fehlerbehandlung
hell:
If Err.Number = -2147467259 Then Resume     'Datenbank wird bereits verwendet
Err.Clear
Set cmd = Nothing
con.Close
Set con = Nothing
End Sub
Private Sub TextBox_Model_Change()
Call Listbox_SQL("Select Tier from Tierreich as mytab where [mytab.Tier] like '%" & UF_Wahl. _
TextBox_Model & "%'")
End Sub
'DIM after: 0
'SET Con after: 0,125
'RS after: 0,4375
'Listbox after: 1,109375