Visual Basic para Aplicaciones - RARO: Funcion DIR vbDirectory no me encuentra algunas carpetas ¿?

Saludos, en resumen tengo implementada la función DIR pero hay algunas carpetas que me devuelve vacío como que no existen y si que existen. Para hacer la prueba introducí este código para ir viendo el valor de a:

Dim a As String
a = Dir(destino2, vbDirectory)

Curiosamente solo me encuentra las primeras carpetas no he sabido determinar hasta cual (mas o menos hasta la numero 50), y las demás me sale a = "" , porque pasa esto? q estoy haciendo mal? A ver si podéis darme alguna pista. GRACIAS


destino2 = la variable de la ruta donde esta la carpeta
Para hacer diferentes pruebas, he puesto la ruta directamente en vez de la variable y lo mismo...

Efectivamente parece ser que la funcion Dir() da problemas buscando en otros sitios para listar directorios en una ruta determinada recomiendan utilizar entre otras FileSystemObject
Pero previamente tendras que activar la biblioteca Scrrun.dll
En el Editor de VBA - Herramientas - Referencias

Deberia estar ubicada en C:\Windows\System32\Scrrun.dll

En el siguiente ejemplo presenta los directorios exitentes un la ruta contenida den path

sub Prueba

Dim fso As New FileSystemObject
Dim f As Folder, sf As Folder, path As String
path = "C:\"
Set f = fso.GetFolder(path)
For Each sf In f.SubFolders
MsgBox sf.Name
Next

End Sub

GRACIAS cmgcharli, y para que en vez de listarmelos simplemete me diga si existe o no? como dir, q si lo cuentra muestra la ruta y si no en blanco...
A ver si con esta función no me pasa lo q menciono de google drive... q cosas mas raras

Una pregunta, se puede utilizar getfolder con caracteres comodín "*" tal y como permite Dir? es porque sinó no me vale...

Si el nombre de todos tus directorios empieza siempre por el número o codigo a buscar puedes hacer lo siguiente

VarCodigo= contiene los caracteres o numeros a buscar

For Each sf In f.SubFolders

if len(sf.name)>=len(varcodigo) then

If mid(sf.name,1,len(varcodigo))=varcodigo then

AQUI ES DONDE PUEDE TRABAJAR CON EL DIRECTORIO ENCONTRADO

msgbox sf.name

SI EXISTEN MAS QUE CUMPLAN EL CRITERIO Y LOS QUIERES NO
PONGAS EL EXIT FOR

EXIT FOR
end if

end if

Next

Gracias cmgcharli por tu respuesta, pero donde pongo la ruta de la carpeta que incluye todas las subcarpetas en las q tengo q buscar?

Bueno, ya he descubierto, mas o menos q pasa:
La búsqueda la hago en una carpeta de mi pc pero que está compartida con google drive, este cambia los iconos de las carpetas poniendoles un tick verde y un muñeco como de compartido azul, pues no se porque razón en esas carpetas no me realiza la búsqueda....
Yo le he puesto el atributo vbDirectory, sabeis si se le pueden poner varios atributos? gracias

sub prueba

Dim fso As New FileSystemObject
Dim f As Folder
sf As Folder
path As String

ESTA ES LA VARIABLE QUE CONTIENE LA RUTA EN DONDE VA HA BUSCAR LAS CARPETAS

path = "C:\"

Set f = fso.GetFolder(path)

For Each sf In f.SubFolders

if len(sf.name)>=len(varcodigo) then

If mid(sf.name,1,len(varcodigo))=varcodigo then

AQUI ES DONDE PUEDE TRABAJAR CON EL DIRECTORIO ENCONTRADO

msgbox sf.name

SI EXISTEN MAS QUE CUMPLAN EL CRITERIO Y LOS QUIERES NO
PONGAS EL EXIT FOR

EXIT FOR
end if

end if

Next

end sub

Hola cmgcharli, muchas gracias, he probado el ultimo cóigo que me pasas y si que funciona , he observado que recorre una a una todas las subcarpetas de la ruta.

Pero mi problema ahora es que no se como enlazarlo, yo necesito:
- Que me busque en todas las subcarpetas,
- si existe la subcarpeta identica que me guarde un archivo
- si existe la subcarpeta que empieza por el mismo nº que me envíe un mensaje (tu codigo)
- si no encuentra la subcarpeta ni ninguna que comience igual q la cree
Yo con dir lo he resuelto de la siguiente manera: (que funciona excepto en las carpetas creadas con google drive que les pone un icono raro), como podría hacer todo este enlace con tu código? esq me lío con el for each y los ifs....
-------------------------------------------------------------------------------------
If Dir(destino2, vbDirectory) = "" Then
Set fso = CreateObject("Scripting.FileSystemObject")
MkDir _
"\\atpsrv\COMERCIAL\PROYECTOS COMERCIAL\PROYECTOS" & "\" & numero + " " + proyecto + " " + "-" + " " + cliente

MkDir _
"\\atpsrv\COMERCIAL\PROYECTOS COMERCIAL\PROYECTOS" & "\" & numero + " " + proyecto + " " + "-" + " " + cliente + "\" + "Escandallos"

ActiveWorkbook.SaveAs Filename:= _
archivo _
, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False

ActiveSheet.Name = newName
ActiveWorkbook.Save
ActiveWorkbook.Close

Windows("Base de Costes.xlsm").Activate

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
archivo2 _
, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=False

ElseIf Dir(destino3, vbDirectory) = "" Then

MsgBox " Numero de Proyecto ya creado en Proyectos Comercial, compruebe que el proyecto y el cliente están escritos igual que la carpeta, GRACIAS"

Exit Sub

Else


ActiveWorkbook.SaveAs Filename:= _
archivo _
, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False

ActiveSheet.Name = newName
ActiveWorkbook.Save
ActiveWorkbook.Close

Windows("Base de Costes.xlsm").Activate

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
archivo2 _
, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=False
End If
------------------------------------------------------------------

Se me ocurre crear una funcion con el codigo de For Each pasandole como argumento la Ruta donde debe buscar y el Codigo que debe buscar y nos devuelva si existe el valor True y si no existe el valor False

Function BuscarDirectorios(AVarRuta as string, AVarCodigo as String) as Boolean

Dim fso As New FileSystemObject
Dim f As Folder
Dim sf As Folder
Dim path As String

BuscarDirectorios=False

path = AvarRuta

Set f = fso.GetFolder(path)

For Each sf In f.SubFolders

if len(sf.name)>=len(Avarcodigo) then

If mid(sf.name,1,len(Avarcodigo))=Avarcodigo then

BuscarDirectorios=true

Exit Function

End if

End if

Next

End Function

AQUI PONEMOS TU CODIGO CON LA DIFERENCIA QUE EN LUGAR DE USAR LA FUNCION DIR() UTILIZAMOS LA FUNCION QUE HEMOS CREADO PASANDO COMO PARAMENTRO LA RUTA DONDE QUEREMOS QUE NOS BUSQUE LAS CARPETAS

If BuscarDirectoiros(Ruta, Codigo)=False Then
Set fso = CreateObject("Scripting.FileSystemObject")
MkDir _
"\\atpsrv\COMERCIAL\PROYECTOS COMERCIAL\PROYECTOS" & "\" & numero + " " + proyecto + " " + "-" + " " + cliente

MkDir _
"\\atpsrv\COMERCIAL\PROYECTOS COMERCIAL\PROYECTOS" & "\" & numero + " " + proyecto + " " + "-" + " " + cliente + "\" + "Escandallos"

ActiveWorkbook.SaveAs Filename:= _
archivo _
, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False

ActiveSheet.Name = newName
ActiveWorkbook.Save
ActiveWorkbook.Close

Windows("Base de Costes.xlsm").Activate

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
archivo2 _
, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=False

ElseIf BuscarDirectoiros(Ruta, Codigo)=False Then

MsgBox " Numero de Proyecto ya creado en Proyectos Comercial, compruebe que el proyecto y el cliente están escritos igual que la carpeta, GRACIAS"

Exit Sub

Else


ActiveWorkbook.SaveAs Filename:= _
archivo _
, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False

ActiveSheet.Name = newName
ActiveWorkbook.Save
ActiveWorkbook.Close

Windows("Base de Costes.xlsm").Activate

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
archivo2 _
, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=False
End If



end sub

Hola cmgcharli, gracias por tu ayuda, pero al final no se como se me ha encendido la bombilla y decidí juntar dos atributos en la función Dir, vbdirectory + vbsystem, por lo visto no me buscaba algunas carpetas porque no se porque son de sistema... con esto ya me busca en todas las subcarpetas! Lo pregunté en el foro y me dijeron que con el signo + se podían poner varios atributos. De momento funciona! Muchas gracias por tu gran ayuda y por tu tiempo! si no me funcionara utilizo el codigo que me has dicho

No se si estos parametros puedan ayudar en algo

Dir(RutaProg, vbDirectory + vbHidden + vbBinaryCompare)

ó

Dir(RutaProg, FileAttribute.Directory + FileAttribute.Hidden + FileAttribute.System)