VBA - Opening or getting location for file where I don't know exactly where the file is saved or exactly what it is called

[excelquestion55]

At my job I have a bunch of products - about 1,600. For each product, we have recipe cards saved on excel. These are in a folder ("Meals") containing subfolders (eg. "Foils"). In these subfolder, are the excel recipe cards and another subfolder called "Archive" which has the old versions. If I have a product code eg. 324787, I would search this in file explorer and open the most up to date one. Can I do this on VBA? The other complication is that the recipes have no naming structure other than the fact that the 6 digit product code will be there somewhere. Thanks!

I have code to search for the file but I have no idea about how to then open the file - or get the file locations as I could then open it from this.

Sub SearchFiles()
Call Shell("explorer.exe " & Chr(34) & "search-ms:query= ***CODE*** &crumb=location: ***FILE LOCATION*** " & Chr(34), vbNormalFocus)
End Sub

 

[Gokhan Aycan]

Hey, it is possible.

Are there any non product code numbers just before or after the code itself? i.e., 7 numbers in succession?
Do you want to also check inside Archive?

Edit: Do I get the recipes?

 

[excelquestion55]

Thanks. The excel's are always called 6 digit code space v something space product name eg. 123456 v7 steak pie (but the product name is standardised).
They're actually ingredients not recipes

 

[John_w]

Try this macro, changing the two strings where indicated. An InputBox prompt could be used to enter the product code. If the product code only exists in the Archive folder the macro could be tweaked to display a warning and not open the found workbook.

Public Sub Find_and_Open_Product_Workbook()

    Dim mainFolder As String, productCode As String
    Dim dirLines As Variant
    Dim wb As Workbook
       
    mainFolder = "C:\path\to\Meals\"            'change
    productCode = "123456"                      'change
   
    If Right(mainFolder, 1) <> "\" Then mainFolder = mainFolder & "\"
    dirLines = Split(CreateObject("wscript.shell").exec("cmd /c DIR /B /S /A-D /O-D " & Chr(34) & mainFolder & "*" & productCode & "*.xlsx" & Chr(34)).StdOut.ReadAll, vbCrLf)
   
    If UBound(dirLines) >= 0 Then
        Set wb = Workbooks.Open(dirLines(0))
    Else
        MsgBox "Excel workbook with file name containing product code '" & productCode & "' not found in " & mainFolder & " and its subfolders", vbExclamation, "Open Product workbook"
    End If
   
End Sub

 

[Gokhan Aycan]

Below, just change the strFolder variable to your Meals folder. You will be prompted with an InputBox that lists all files that have the product code as 1,2,3, etc. showing path and modified date. 0 (zero) is the most recent one and is the default value of inputbox. See if you like it.

Product code at the moment is the value of the activecell, as John_W's code, an input box can be added to ask for the code.
The commented parts are for early binding.

Paste in a standard module:

Option Explicit

Dim strProductCode As Variant
'Dim oDict As Scripting.Dictionary
Dim oDict As Object

Public Sub Find_Recipe()
    
    strProductCode = IIf(Len(CStr(ActiveCell.Value)) = 6 And IsNumeric(ActiveCell.Value), CStr(ActiveCell.Value), "")
    
    If strProductCode = "" Then
        MsgBox "Product code not suitable!", vbOKOnly, "Warning"
        Exit Sub
    End If
    
    'Dim fso As FileSystemObject
    'Set fso = New FileSystemObject
    
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")

    Dim strFolder As String
    strFolder = "D:\Test VBA\Meals"

    'Set oDict = New Scripting.Dictionary
    Set oDict = CreateObject("Scripting.Dictionary")
    
    Call Get_SubFolders(fso.GetFolder(strFolder))
    
    Dim i As Long
    
    Dim Date_LastModified As Date
    Dim File_LastModified As String
    
    If oDict.Count > 0 Then
    
        Date_LastModified = oDict.Items()(0)
        File_LastModified = oDict.Keys()(0)
        
        Dim strInput As String
        
        strInput = ""
        
        For i = 0 To oDict.Count - 1
            strInput = strInput & Chr(10) & i + 1 & ") " & Right(oDict.Keys()(i), Len(oDict.Keys()(i)) - Len(strFolder) - 1) & " - " & oDict.Items()(i)
            If DateDiff("s", Date_LastModified, oDict.Items()(i)) > 0 Then
                Date_LastModified = oDict.Items()(i)
                File_LastModified = oDict.Keys()(i)
            End If
        Next i
        
        strInput = "0) " & Right(File_LastModified, Len(File_LastModified) - Len(strFolder) - 1) & " - " & Date_LastModified & Chr(10) & strInput
        
        Dim answer As Variant
re_input:
        answer = InputBox(strInput, "Select to Open", "0")
        
        If answer <> "" Then
        
            If IsNumeric(answer) Then
                answer = CInt(answer)
                If answer <= oDict.Count Then
                    If answer = 0 Then
                        Workbooks.Open (File_LastModified)
                    Else
                        Workbooks.Open (oDict.Keys()(answer))
                    End If
                Else
                    MsgBox "Please enter a valid number", vbOKOnly, "Warning"
                    GoTo re_input
                End If
            Else
                MsgBox "Please enter a valid number", vbOKOnly, "Warning"
                GoTo re_input
            End If
        End If
    End If
    
    Set oDict = Nothing
    Set fso = Nothing
    
End Sub

Private Function Get_SubFolders(ByVal oFolder) ' As Folder) as Folder
    
'    Dim oSubFolder As Folder
'    Dim oFile As File
    
    Dim oSubFolder
    Dim oFile
    
    For Each oSubFolder In oFolder.SubFolders
    
        Get_SubFolders oSubFolder
    
    Next oSubFolder
        
    For Each oFile In oFolder.Files
        If InStr(oFile.Name, strProductCode) And InStr(oFile.Path, ".xls") Then
            oDict(oFile.Path) = oFile.DateLastModified
        End If
    Next oFile
    
End Function

 

[excelquestion55]

Thanks guys!

John - You're code is very good. However, there is one thing I hadn't realised. I some folders there is "current" and "archive" and it's opening the last modified in the archive folder - not the last modified in the "current" folder or last modified overall (is it cause archive is before current alphabetically). Also, could I modify this so it returns the file path in say cell A1 (without opening it so it's not too slow)

Gokhan - I can't get yours to work as it fails at oDict(oFile.Path) towards the end

 

[Gokhan Aycan]

I can't reproduce, working as expected here so need your help to debug. Not exactly nice looking as is, maybe need another chr(10) between file name and date

Which line exactly? And what error do you get?

 

[GWteB]

Both @John_w's and @Gokhan Aycan's code depend on the folder structure, so it is more or less a coincidence if the most recently modified file is found.
How about ...

Public Sub Excelquestion55()

    Const SEARCHFOLDER          As String = "C:\Users\Excelquestion55\documents"    ' <<<<<<<<  change to suit
    Const SEARCHFORINFILENAME   As String = "563412"                                ' <<<<<<<<  change to suit

    Dim oDict As Object, FullName As String, FileDate As Date
    Set oDict = CreateObject("Scripting.Dictionary")
    GetFiles SEARCHFOLDER, "*" & SEARCHFORINFILENAME & "*.xls?", oDict
    If Not oDict.Count = 0 Then
        DictSortByValue oDict, xlDescending
        FullName = oDict.Keys()(0)
        FileDate = oDict.Items()(0)
        
        MsgBox "This file is about to be opened:" & vbNewLine & FullName & vbNewLine & "last modified on " & FileDate, vbInformation
        Application.Workbooks.Open FullName
    Else
        MsgBox "Couldn't find any filename containing: " & vbNewLine & SEARCHFORINFILENAME & vbNewLine & _
                "within folder: " & vbNewLine & _
                SEARCHFOLDER & vbNewLine & "or its subfolders."
    End If
    Set oDict = Nothing
End Sub


Public Sub GetFiles(ByVal argSourcePath As String, ByVal argFileSpec As String, ByRef argDictionary As Object)

    Dim FSO As Object, oRoot As Object, oFile As Object, oFolder As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FolderExists(argSourcePath) And Not argFileSpec = vbNullString And Not argDictionary Is Nothing Then
        Set oRoot = FSO.GetFolder(argSourcePath)
        For Each oFile In oRoot.Files
            If oFile.Name Like argFileSpec Then
                argDictionary.Add oFile.Path, oFile.DateLastModified
            End If
        Next oFile
        For Each oFolder In oRoot.SubFolders
            Call GetFiles(oFolder.Path, argFileSpec, argDictionary)
        Next oFolder
    End If
End Sub


Public Sub DictSortByValue(ByRef argDict As Object, Optional ByVal argSortOrder As XlSortOrder = xlAscending)

    Dim arrList As Object, dictTmp As Object
    Dim coll    As Collection
    Dim vKey    As Variant, vValue As Variant, vItem As Variant
    Set arrList = CreateObject("System.Collections.ArrayList")
    Set dictTmp = CreateObject("Scripting.Dictionary")
    On Error GoTo SUB_ERROR
    For Each vKey In argDict
        vValue = argDict(vKey)
        If Not dictTmp.Exists(vValue) Then
            Set coll = New Collection
            dictTmp.Add vValue, coll
            arrList.Add vValue
        End If
        dictTmp(vValue).Add vKey
    Next vKey
    arrList.Sort
    If argSortOrder = xlDescending Then
        arrList.Reverse
    End If
    argDict.RemoveAll
    For Each vValue In arrList
        Set coll = dictTmp(vValue)
        For Each vItem In coll
            argDict.Add vItem, vValue
        Next vItem
    Next vValue

SUB_DONE:
    dictTmp.RemoveAll
    Set dictTmp = Nothing
    Set arrList = Nothing
    Exit Sub

SUB_ERROR:
    If Err.Number = 450 Then
        Err.Clear
        arrList.Clear
        Set arrList = Nothing
        Set dictTmp = Nothing
        Set coll = Nothing
        Err.Raise Number:=vbObjectError + 100, _
                  Source:="Procedure: DictSortByValue", _
                  Description:="Cannot sort the dictionary if the value is an object"
    End If
End Sub

 

[Gokhan Aycan]

@GWteB Mine checks for modified date

            If DateDiff("s", Date_LastModified, oDict.Items()(i)) > 0 Then
                Date_LastModified = oDict.Items()(i)
                File_LastModified = oDict.Keys()(i)
            End If

 

[GWteB]

It sure does, but it's not giving me the last modified file.