Open file IF

[ZTK]

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:

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

 

[DanteAmor]

Try this:

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

 

[ZTK]

Try this:

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

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.