Open file IF

ZTK

Board Regular
Joined
Aug 20, 2021
Messages
51
Office Version
  1. 2019
Platform
  1. Windows
Good day.

I come to you since here I have learned quite a few details about VBA.

I have a macro that works perfectly for me, thanks to a forum on this WEB I was able to put it together according to my needs.

Its function is to open a file from a folder, generally the files have generic names, for example "BRANCH _XXX_AGOSTO" the only value that changes is the month.

What I would like is that if you cannot find the file corresponding to the current month, open the one from the previous month (based on the example it would be the month of July), either through a confirmation / notice MSBOX or directly open it.

I attach the MACRO that I have:




VBA Code:
Dim xfolders As New Collection



Sub Buscar_Fichas_de_Datos()

Dim sPath As String

Dim xfold As Variant, arch As Variant

Dim bexist As Boolean

Dim sPartialName As String

Dim Mensaje As String



Set xfolders = Nothing

sPath = "C:\Users\Miguel Angel\Desktop\MIGUEL\FORMATOS pruebas\FICHAS pruebas"

xfolders.Add sPath 'CORRIGE DIRECTORIO

Mensaje = "¿Qué sucursal buscas?"

sPartialName = InputBox(Mensaje, "Centro de Control")

Call AddSubDir(sPath)

For Each xfold In xfolders

arch = Dir(xfold & "\" & "Sucursal" & " " & sPartialName & " " & Application.WorksheetFunction.Proper(MonthName(VBA.Month(Date), False)) & ".*")

If arch <> "" Then Exit For

Next

If arch = "" Then



MsgBox "No se encontró el archivo"

Else

ActiveWorkbook.FollowHyperlink xfold & "\" & arch

End If

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
 
Last edited by a moderator:

Excel Facts

How to find 2nd largest value in a column?
MAX finds the largest value. =LARGE(A:A,2) will find the second largest. =SMALL(A:A,3) will find the third smallest
Try this:

VBA Code:
Dim xfolders As New Collection

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\Miguel Angel\Desktop\MIGUEL\FORMATOS pruebas\FICHAS pruebas"
  sPath = "C:\trabajo"
  
  xfolders.Add sPath 'CORRIGE DIRECTORIO
  Mensaje = "¿Qué sucursal buscas?"
  sPartialName = InputBox(Mensaje, "Centro de Control")
  sName = "Sucursal" & " " & 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("No se encontró el archivo. " & sName & sMonth & vbCr & _
                "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
 
  • Like
Reactions: ZTK
Upvote 0
Try this:

VBA Code:
Dim xfolders As New Collection

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\Miguel Angel\Desktop\MIGUEL\FORMATOS pruebas\FICHAS pruebas"
  sPath = "C:\trabajo"
 
  xfolders.Add sPath 'CORRIGE DIRECTORIO
  Mensaje = "¿Qué sucursal buscas?"
  sPartialName = InputBox(Mensaje, "Centro de Control")
  sName = "Sucursal" & " " & 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("No se encontró el archivo. " & sName & sMonth & vbCr & _
                "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 INFINITELY

WORKS PERFECTLY
 
Upvote 0

Forum statistics

Threads
1,223,237
Messages
6,170,928
Members
452,366
Latest member
TePunaBloke

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