Macro to open file from subfolders

Z

ZTK

Board Regular
Joined
Aug 20, 2021
Messages
51
Office Version
  1. 2019
Platform
  1. Windows
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.
 

Excel Facts

Back into an answer in Excel
Use Data, What-If Analysis, Goal Seek to find the correct input cell value to reach a desired result
Sort by date Sort by votes
Try this:

VBA Code: 
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.
 
Upvote 0
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.
 
Upvote 0
DanteAmor said:
Try this:

VBA Code: 
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.
Click to expand...


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
 
Upvote 0
ZTK said:
giving it "cancel"
Click to expand...
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.
 
  • Like
Reactions: ZTK
Upvote 0
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.
Click to expand...
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"?
 
Upvote 0
ZTK said:
Just when starting it, when it asks to type the 3 digits
Click to expand...
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"?
Click to expand...
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.


VBA Code: 
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
 
  • Like
Reactions: ZTK
Upvote 0
Solution
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.


VBA Code: 
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
Click to expand...
Thank you so much for all your time and support.

It was excellent
 
Upvote 0
You must log in or register to reply here.

Similar threads

rjplante
  • Question
Directory macro not working on certain computers
Replies
4
Views
347
rjplante
rjplante
rjplante
  • Solved
Code following macro doesn't run
Replies
1
Views
254
rjplante
rjplante
M
  • Question
Search in folders/subfolders: Tweaking a previous solution
Replies
4
Views
994
John_w
J
Z
  • Question
Open file IF
Replies
3
Views
504
DanteAmor
DanteAmor
I
  • Question
Saving as pdf file from another sheet
Replies
1
Views
428
ipbr21054
I

Forum statistics

Threads
1,214,823
Messages
6,121,777
Members
449,049
Latest member
greyangel23

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top