# Macro to open file from subfolders



## ZTK (Jan 2, 2023)

Good day; I ask for your help, I already have a macro that helps me open a file from a specific path, the detail is that every month the name of the folder changes, I would like to see the possibility of leaving as a "general" path, let's say, the desktop of my PC and from there to look for the file in some other of the subfolders.

As an example, this month the folder where the file is located is possibly called "January 01", the following month it could be "Logs" and so on; Inside these folders there are files with 3-digit numbers + the name of the month.

The Macro that I have already does the function of opening the file if I only put the name of the first 3 digits, but as I mentioned, I would like to "expand" the search range from the desktop and from there to the next subfolder.

I don't know if I understand myself.

The code I have is the following:

Sub Buscar_Fichas_de_Datos()

Dim sPath As String, sName As String, sMonth As String
Dim xfold As Variant, arch As Variant
Dim bexist As Boolean
Dim sPartialName As String
Dim Mensaje As String
Dim m As Long, n As Long

Set xfolders = Nothing
sPath = "C:\Users\XXXXX\Desktop\Datos Diciembre"

xfolders.Add sPath
Mensaje = "¿Qué Ficha buscas?" & vbNewLine & vbNewLine & _
"Escribe el número a 3 dígitos"
sPartialName = InputBox(Mensaje, "Pruebal")
sName = sPartialName & " "
m = VBA.Month(Date)
Call AddSubDir(sPath)

Do While True
sMonth = Application.WorksheetFunction.Proper(MonthName(m, False))
For Each xfold In xfolders
arch = Dir(xfold & "\" & sName & sMonth & ".*")
If arch <> "" Then Exit For
Next
If arch = "" Then
If MsgBox("¡¡¡La ficha NO ESTA ACTUALIZADA!!!" & vbNewLine & vbNewLine & _
"¿Abrir el mes anterior?", vbQuestion + vbYesNo, "Abrir Archivo") = vbNo Then
Exit Do
Else
n = n + 1
m = Month(DateSerial(Year(Date), Month(Date) - n, 1))
End If
Else
ActiveWorkbook.FollowHyperlink xfold & "\" & arch
Exit Do
End If
Loop
End Sub
'
Sub AddSubDir(lPath As Variant)
Dim SubDir As New Collection, DirFile As Variant, sd As Variant
If Right(lPath, 1) <> "\" Then lPath = lPath & "\"
DirFile = Dir(lPath & "*", vbDirectory)
Do While DirFile <> ""
If DirFile <> "." And DirFile <> ".." Then
If ((GetAttr(lPath & DirFile) And vbDirectory) = 16) Then
SubDir.Add lPath & DirFile
End If
End If
DirFile = Dir
Loop
For Each sd In SubDir
xfolders.Add sd
Call AddSubDir(sd)
Next
End Sub


I thank you in advance for your attention and support.


----------



## DanteAmor (Jan 2, 2023)

Try this:


```
Option Explicit

Dim xfolders As New Collection

Sub Buscar_Fichas_de_Datos()
  Dim sPath As String, sName As String, sMonth As String, sPartialName As String, Mensaje As String
  Dim xfold As Variant, arch As Variant
  Dim bexist As Boolean
  Dim m As Long, n As Long
 
  Set xfolders = Nothing
  sPath = Environ("USERPROFILE") & "\Desktop\"
 
  xfolders.Add sPath
  Mensaje = "¿Qué Ficha buscas?" & vbNewLine & vbNewLine & _
    "Escribe el número a 3 dígitos"
  sPartialName = InputBox(Mensaje, "Pruebal")
  sName = sPartialName & " "
  m = VBA.Month(Date)
  Call AddSubDir(sPath)
 
  Do While True
    sMonth = Application.WorksheetFunction.Proper(MonthName(m, False))
    For Each xfold In xfolders
      arch = Dir(xfold & "\" & sName & sMonth & ".*")
      If arch <> "" Then Exit For
    Next
    If arch = "" Then
      If MsgBox("¡¡¡La ficha NO ESTA ACTUALIZADA!!!" & vbNewLine & vbNewLine & _
        "¿Abrir el mes anterior?", vbQuestion + vbYesNo, "Abrir Archivo") = vbNo Then
        Exit Do
      Else
        n = n + 1
        m = Month(DateSerial(Year(Date), Month(Date) - n, 1))
      End If
    Else
      ActiveWorkbook.FollowHyperlink xfold & "\" & arch
      Exit Do
    End If
  Loop
End Sub
'
Sub AddSubDir(lPath As Variant)
  Dim SubDir As New Collection, DirFile As Variant, sd As Variant
  If Right(lPath, 1) <> "\" Then lPath = lPath & "\"
  DirFile = Dir(lPath & "*", vbDirectory)
  Do While DirFile <> ""
    If DirFile <> "." And DirFile <> ".." Then
      If ((GetAttr(lPath & DirFile) And vbDirectory) = 16) Then
        SubDir.Add lPath & DirFile
      End If
    End If
    DirFile = Dir
  Loop
 
  For Each sd In SubDir
    xfolders.Add sd
    Call AddSubDir(sd)
  Next
End Sub
```

*Note Code Tag:*
In future please use code tags when posting code.
*How to Post Your VBA Code* it makes your code easier to read and copy and it also maintains VBA formatting.


----------



## Peter_SSs (Jan 2, 2023)

Cross-posting (posting the same question in more than one forum) is not against our rules, but the *method* of doing so is covered by #13 of the Forum Rules.

*Be sure to follow & read the link at the end of the rule too!*

Cross posted at: Macro para Abrir archivo con nombre parcial en cualquier carpeta
If you have posted the question at more places, please provide links to those as well.

If you do cross-post in the future and also provide links, then there shouldn’t be a problem.


----------



## ZTK (Jan 3, 2023)

DanteAmor said:


> Try this:
> 
> 
> ```
> ...




It works perfect!!!!

Taking advantage of the attention:
Is there a way to fix one more detail?
When executing the macro and giving it "cancel" it goes to the next step, as such it is not cancelled, it is a minimal detail but I would love to polish it

Thank you in advance for the help provided


----------



## DanteAmor (Jan 4, 2023)

ZTK said:


> giving it "cancel"


In which part of the macro do you give "*cancel*", I don't see, the only part of the macro is when the message to continue "Si" or "No" appears, if you press "No" the process ends.


----------



## ZTK (Jan 4, 2023)

DanteAmor said:


> In which part of the macro do you give "*cancel*", I don't see, the only part of the macro is when the message to continue "Si" or "No" appears, if you press "No" the process ends.


Just when starting it, when it asks to type the 3 digits

This if by mistake the button was clicked (to which I have it assigned)

In the same way, it can be improved so that it opens the most recent tab (if it exists) without asking if you want to open the one from the previous month?

And if that were not the case, would it send a notice like "does not exist"?


----------



## DanteAmor (Jan 4, 2023)

ZTK said:


> Just when starting it, when it asks to type the 3 digits


Ok. I added the following line `If sPartialName = "" Then Exit Sub`



ZTK said:


> In the same way, it can be improved so that it opens the most recent tab (if it exists) without asking if you want to open the one from the previous month?
> And if that were not the case, would it send a notice like "does not exist"?


The cycle will be repeated 12 times, that is, it will look for the file 12 months back, if it does not find it, it will send the message "No existe". I set a limit of 12 months, because if a limit is not set, it would enter an endless loop.



```
Option Explicit

Dim xfolders As New Collection

Sub Buscar_Fichas_de_Datos()
  Dim sPath As String, sName As String, sMonth As String, sPartialName As String, Mensaje As String
  Dim xfold As Variant, arch As Variant
  Dim bexist As Boolean
  Dim m As Long, n As Long, x As Long
  
  Set xfolders = Nothing
  sPath = Environ("USERPROFILE") & "\Desktop\"
  
  xfolders.Add sPath
  Mensaje = "¿Qué Ficha buscas?" & vbNewLine & vbNewLine & _
    "Escribe el número a 3 dígitos"
  sPartialName = InputBox(Mensaje, "Pruebal")
  
  If sPartialName = "" Then Exit Sub
  
  sName = sPartialName & " "
  m = VBA.Month(Date)
  Call AddSubDir(sPath)
  
  Do While True
    sMonth = Application.WorksheetFunction.Proper(MonthName(m, False))
    For Each xfold In xfolders
      arch = Dir(xfold & "\" & sName & sMonth & ".*")
      If arch <> "" Then Exit For
    Next
    If arch = "" Then
      'If MsgBox("¡¡¡La ficha NO ESTA ACTUALIZADA!!!" & vbNewLine & vbNewLine & _
      '  "¿Abrir el mes anterior?", vbQuestion + vbYesNo, "Abrir Archivo") = vbNo Then
      '  Exit Do
      'Else
        n = n + 1
        m = Month(DateSerial(Year(Date), Month(Date) - n, 1))
        x = x + 1
        If x = 12 Then
          MsgBox "no existe"
          Exit Do
        End If
      'End If
    Else
      ActiveWorkbook.FollowHyperlink xfold & "\" & arch
      Exit Do
    End If
  Loop
End Sub
'
Sub AddSubDir(lPath As Variant)
  Dim SubDir As New Collection, DirFile As Variant, sd As Variant
  If Right(lPath, 1) <> "\" Then lPath = lPath & "\"
  DirFile = Dir(lPath & "*", vbDirectory)
  Do While DirFile <> ""
    If DirFile <> "." And DirFile <> ".." Then
      If ((GetAttr(lPath & DirFile) And vbDirectory) = 16) Then
        SubDir.Add lPath & DirFile
      End If
    End If
    DirFile = Dir
  Loop
  
  For Each sd In SubDir
    xfolders.Add sd
    Call AddSubDir(sd)
  Next
End Sub
```


----------



## ZTK (Jan 4, 2023)

Thank you so much for all your time and support. it was excellent


DanteAmor said:


> Ok. I added the following line `If sPartialName = "" Then Exit Sub`
> 
> 
> The cycle will be repeated 12 times, that is, it will look for the file 12 months back, if it does not find it, it will send the message "No existe". I set a limit of 12 months, because if a limit is not set, it would enter an endless loop.
> ...


Thank you so much for all your time and support. 

It was excellent


----------

