Visual Basic - Velocidad de busqueda EN RED

Hola, tengo un pequeño problemilla de tiempo de espera en un programilla que estoy haciendo. Lo expongo: tengo una hoja de excel y tengo que hacer que mediante un criterio (una palabra, fecha, etc) me busque este criterio en aproximadamente 5000 carpetas de unas 7 o 8 palabras cada carpeta leyendo palabra por palabra y me devuelva la ruta de la carpeta/s en contrada/s en un listbox. Bien, esto lo tengo hecho. el problema es que lo busca en el servidor de la empresa (en red) y tengo un tiempo de espera de búsqueda de 37 segundos hasta que me devuelve la información. El problema es que a mi jefe le parece mucho... aclarar que yo no soy programador..... aún que lo estudié en su dia y que estoy bastante verde ya que llevo 5 años sin programar ni casi tocar un pc como quien dice.

a continuación expongo el código de búsqueda haber si alguién me puede dar alguna idea de como mejorarlo o de como optimizar el visual, el xp, los servicios de red o algo que me pueda ayudar...... os lo agradezco de antemano.
-----------------------------------------------------------------------------------------------------------------------
Dim Subdirectorio As Folder

Dim texto As String
Dim busqueda As String
Dim i As Integer

Dim text1 As String
Dim fso As FileSystemObject
Dim El_Directorio As Folder
---------------------------------------------------------------------------------------------------------------------------
Private Sub CommandButton1_Click()
On Error GoTo errsub

On Error Resume Next
Screen.MousePointer = vbHourglass

text1 = "X:\"
DoEvents
ListBox1.Clear


Set fso = New FileSystemObject
Set El_Directorio = fso.GetFolder(Trim$(text1))
Label_espere.Visible = True ' muestra la etiqueta de espere unos instantes
Worksheets(1).Range("M" & 25).Value = "1" ' ESTA LINEA MARCA 1 POR QUE ES BOTON 1 DE PROVINCIA


' Comienza a listar las carpetas
Call Listar_Directorios(El_Directorio)

Screen.MousePointer = vbDefault
Label_espere.Visible = False
'Error
Exit Sub

errsub:
MsgBox Err.Description, vbCritical
Screen.MousePointer = vbDefault

'If Worksheets(1).Range("A" & 4).Value = strAvila Then

End Sub

---------------------------------------------------------------------------------------------------------------------------
Private Sub Listar_Directorios(ByVal El_Directorio As Folder)

On Error GoTo errsub

' Recorre los subdirectorios
For Each Subdirectorio In El_Directorio.SubFolders

File = El_Directorio.Path & "\" & Subdirectorio.Name
Path = Left(File, Len(File) - Len(Dir(File)))
texto = Path

busqueda = Worksheets(1).Range("A" & 2).Value
i = InStr(1, texto, busqueda, 1)
If i > 0 Then
ListBox1.AddItem El_Directorio.Path & "\" & Subdirectorio.Name
Else
End If

'sigue listando los directorios
Listar_Directorios Subdirectorio

Next

Exit Sub

'Error
errsub:
'Error de permiso denegado
If Err.Number = 70 Then
Resume Next

ElseIf Err.Number = 91 Then
Label_espere.Visible = False
Screen.MousePointer = vbDefault
Exit Sub
Else
Label_espere.Visible = False
MsgBox Err.Description, vbCritical
Exit Sub
End If

Label_espere.Visible = False

End Sub