open different files extensions based on cell value

[Hasson]

hi

I look for macro to search any file extension (docx,pdf,jpg. .and so on ) , if there is existed then should open , if there is not existed the file not existed then show message inform me this is not available.

the cell which fill the file name should b1(note: if it's possible write without extension of file) and the directory contains many folders and subfolders in this directory "C:\Users\cmm\Desktop\search"

 

[DanteAmor]

The next one will look for the first file with the name you have in cell B1 (without extension) and open it.

Dim xfolders As New Collection

Sub Search_for_a_file()
  Dim sPath As String
  Dim xfold As Variant, arch As Variant
  
  sPath = "C:\Users\cmm\Desktop\search"
  Call AddSubDir(sPath)
  For Each xfold In xfolders
    arch = Dir(xfold & "\" & Range("B1") & ".*")
    If arch <> "" Then Exit For
  Next
  If arch = "" Then
    MsgBox "is not available"
  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

 

[Hasson]

thanks it works perfectly . I'm afraid repeat the files names but the different is in extension so if it's possible open the same files names with different extensions or I have to write the extensions . what you suggest for the best way ?

 

[DanteAmor]

Do you want to open all files with the same name?
Try this:

Dim xfolders As New Collection

Sub Search_for_a_file()
  Dim sPath As String
  Dim xfold As Variant, arch As Variant
  Dim bexist As Boolean
  
  Set xfolders = Nothing
  sPath = "C:\Users\cmm\Desktop\search"
  sPath = "C:\trabajo"
  Call AddSubDir(sPath)
  For Each xfold In xfolders
    arch = Dir(xfold & "\" & Range("B1") & ".*")
    Do While arch <> ""
      bexist = True
      ActiveWorkbook.FollowHyperlink xfold & "\" & arch
      arch = Dir()
    Loop
  Next
  If bexist = False Then
    MsgBox "is not available"
  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

 

[Hasson]

it gives error "object required" in this line

xfolders.Add sd

 

[DanteAmor]

This line goes to the beginning of all code.

Dim xfolders As New Collection

And delete this line, I use it for my tests

sPath = "C:\trabajo"

 

[Hasson]

now it gives another error " bad file name or number" in this line

 If ((GetAttr(lPath & DirFile) And vbDirectory) = 16) Then

 

[DanteAmor]

Check the names of the files, do you have any written in another language?
Do you change directory?
Before it worked.
All that part I did not modify, what I changed was to keep opening files.

 

[Hasson]

I no know what's the problem . yesterday when I told you about error I was using office 2010 even in post #2 it gives error and today I use on office2019 at work the code in post#2 works normally but the code in post#4 doesn't work well . I create files' names (xlsx,txt,docx) are the same name . their names are 1 but when open it gives message MsgBox "is not available" . before all of this it was files are the same name and the extensions are xlsx,docx,txt . it's mr excel , but it jut opens docx ,txt and doesn't open xlsx

I no know what's the problem

 

[DanteAmor]

and doesn't open xlsx

Try this:

Dim xfolders As New Collection

Sub Search_for_a_file()
  Dim sPath As String
  Dim xfold As Variant, arch As Variant
  Dim bexist As Boolean
  
  Set xfolders = Nothing
  sPath = "C:\Users\cmm\Desktop\search"
  Call AddSubDir(sPath)
  For Each xfold In xfolders
    arch = Dir(xfold & "\" & Range("B1") & ".*")
    Do While arch <> ""
      bexist = True
      If Right(arch, 4) Like "*xls*" Then
        Workbooks.Open xfold & "\" & arch
      Else
        ActiveWorkbook.FollowHyperlink xfold & "\" & arch
      End If
      arch = Dir()
    Loop
  Next
  If bexist = False Then
    MsgBox "is not available"
  End If
End Sub
'
Sub AddSubDir(lPath As Variant)
  Dim SubDir As New Collection, DirFile As Variant, sd As Variant
  
  On Error Resume Next
  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