FIltrar subdirectorios que se muestran con VBA

A parte de preguntar voy a compartir esta fantástica macro, que sirve para listar el contenido de ficheros y subdirectorios del directorio que contiene la macro.

Fuente: http://www.hojasdecalculoexcel.com/2008/11/listar-los-archivos-de-un-directorio.html

Lo que no consigo es que pueda delimitar los subdirectorios que se listan. Por ejemplo yo no necesito todos, si no solo los que sean del 2000 al 3000 o aquellos que tengan 5 dígitos, etc, etc.

Sub ficheros_y_subdirectorios_del_directorio()
'Si hay errores, que continúe
On Error Resume Next
'Ocultamos el procedimiento
Application.ScreenUpdating = False
'Creamos el objeto FileSystemObject
Set fso = CreateObject("Scripting.FileSystemObject")
'Informamos de la ruta de donde vamos a obtener
'los ficheros, en este caso, el mismo directorio
'donde tengamos grabado este fichero con el macro
ruta = ActiveWorkbook.Path
'definimos dos variables que necesitaremos,
'para recuperar el nombre de la carpeta, y
'los subdirectorios y ficheros que haya dentro
Set directorio = fso.GetFolder(ruta)
Set subdirectorios = directorio.subfolders
Set ficheros = directorio.Files
'escribimos un encabezado en la celda D6
Range("D6").Select
ActiveCell = "Subdirectorios del directorio:"
'lo ponemos en negrita y subrayado
ActiveCell.Font.Bold = True
ActiveCell.Font.Underline = xlUnderlineStyleSingle
'escribimos los subdirectorios
ActiveCell.Offset(1, 0).Select
' He intendado un condicional aqui pero sin obtener solucion :(
For Each subdirectorio In subdirectorios
'escribimos el nombre del subdirectorio
    ActiveCell = subdirectorio.Name
    'bajamos una fila
    ActiveCell.Offset(1, 0).Select
Next
'a continuación escribimos los ficheros
'pero antes, escribiremos el encabezado
ActiveCell = "Ficheros del directorio:"
'lo ponemos en negrita y subrayado
ActiveCell.Font.Bold = True
ActiveCell.Font.Underline = xlUnderlineStyleSingle
'pasamos a la siguiente fila
ActiveCell.Offset(1, 0).Select
For Each archivo In ficheros
    'escribimos el nombre del fichero
    ActiveCell = archivo.Name
    'bajamos una fila
    ActiveCell.Offset(1, 0).Select
Next
'Limpiamos los objetos
Set fso = Nothing
Set directorio = Nothing
Set subdirectorios = Nothing
Set ficheros = Nothing
'Mostramos el procedimiento
Application.ScreenUpdating = True
End Sub

Espero les sirva de ayuda y también me puedan ayudar a mi, pregunté en el foro de la fuente pero la ultima entrada es del año 2013 y no veo actividad en el hilo.