Access Importar varios archivos txt varias carpet

Lo que deberías hacer es un proceso previo buscando todas las carpetas y después llamar a tu procedimiento tantas veces como subcarpetas haya.
El código podría ser este:
Sub importarInformesDesdeTodasLasCarpetas(ByVal pathInicial As String)
    ReDim matSubCarpetas(1 To 1000) As String
    Dim nSubCarpetas As Integer
    Dim i As Integer
    If Right$(pathInicial, 1) <> "\" Then pathInicial = pathInicial & "\"
    nSubCarpetas = 0
    buscaSubCarpetas pathInicial, matSubCarpetas(), nSubCarpetas
    ' Aquí iría tu proceso para importar los ficheros de una única carpeta
    For i = 1 To nSubCarpetas
        llamadaProcesoImportacion matSubCarpetas(i)
    Next i
End Sub
Sub buscaSubCarpetas(ByVal pathIni As String, ByRef mDir() As String, ByRef nDir As Integer)
    Dim d As String
    Dim i As Integer
    Dim nDirIni As Integer
    Dim nDirFin As Integer
    nDirIni = nDir
    d = Dir$(pathIni & "*", vbDirectory)
    Do While d <> ""
        If d <> "." And d <> ".." Then
            If (GetAttr(pathIni & d) And vbDirectory) = vbDirectory Then    ' Es una subcarpeta
                nDir = nDir + 1
                mDir(nDir) = pathIni & d & "\"
            End If
        End If
        d = Dir$
    Loop
    nDirFin = nDir
    ' Ya hemos leido las carpetas de este directorio. Buscaremos las de sus subdirectorios
    For i = nDirIni + 1 To nDirFin
        buscaSubCarpetas mDir(i), mDir(), nDir
    Next i
End Sub

Buenas de nuevo.
Primero perdona por la tardanza en responder y gracias por tu rápida respuesta.
Le he dado vueltas a tu sugerencia y no me sirve puesto que utilizo el siguiente código para exportar los archivos de una carpeta.
fichero = Dir("C:\Documents and Settings\djzqtz\rpr\producción\2009\S25\*.txt")
    While (Len(fichero) > 0)
            DoCmd.TransferText acImportDelim, "hh", "Producto", fichero, False, ""
            fichero = Dir
    Wend
Me da error.
Así que he creado lo siguiente:
Private Sub Comando0_Click()
Dim diasemana As String, dia As Integer, semana As Byte, mes As Integer, año As Integer, Fecha As Date
DoCmd.SetWarnings (0)
directorio = "C:\Documents and Settings\Mario Cantoral\djzqtz\producción"
Fecha = Now()
For i = 0 To 10
    diasemana = Format(Fecha, "dddd")
    dia = Format(Fecha, "d")
    semana = Format(Fecha, "ww")
    mes = Format(Fecha, "m")
    año = Format(Fecha, "yyyy")
    If dia < 10 And mes < 10 Then archivo = directorio & "\" & año & "\S" & semana & "\0" & dia & "-0" & mes & "-" & año & ".txt"
    If dia < 10 And mes >= 10 Then archivo = directorio & "\" & año & "\S" & semana & "\0" & dia & "-" & mes & "-" & año & ".txt"
    If dia >= 10 And mes < 10 Then archivo = directorio & "\" & año & "\S" & semana & "\" & dia & "-0" & mes & "-" & año & ".txt"
    If dia >= 10 And mes >= 10 Then archivo = directorio & "\" & año & "\S" & semana & "\" & dia & "-" & mes & "-" & año & ".txt"
    archivod = Dir(archivo)
    If archivod = "" Then MsgBox ("El " & diasemana & "  " & dia & "-" & mes & "-" & año & "  no se trabajo.  S" & semana) Else DoCmd.TransferText , "hh", "Producto", archivo, 0
    Fecha = Fecha - 1
Next i
End Sub
Y el tema queda solucionado, me recoge los 10 últimos días, si quisiera más solamente he de añadir más cantidad al contador i del for next y listo.
Muchas gracias por tu trabajo que me ha ayudado a enfocarlo de otra manera.

Pues no entiendo que no funcione el código que te envié porque a mi me funcionó correctamente.
Sólo le faltaba engranchar con tu proceso para importar los datos de una carpeta determinada.
De todas formas... si lo que tienes te funciona, no lo lies más. Al fin y al cabo lo que buscamos es la ejecución correcta.
Si no tienes más consultas sobre el tema cierra la pregunta.

Esta consulta continúa pendiente.
Si no tienes más que preguntar, por favor, cierra la consulta para que no continúe como pendiente.