I have asked this question differently, but here was the answer to find files in a single folder on a networked drive.

Sub GetFilesDetails()
  Dim sh As Worksheet, lastR As Long, arrKeys, arrDate, i As Long, fileName As String
  Dim folderPath As String, lastModifDate As Date, lastDate As Date
  Const key2 As String = "Proof"
  
  Set sh = ActiveSheet 'use here the necessary worksheet
  lastR = sh.Range("B" & sh.rows.count).End(xlUp).Row
  
  arrKeys = sh.Range("B4:B" & lastR).Value2 'place the range in an array for faster iteration
  arrDate = sh.Range("G4:G" & lastR).Value2
 
  folderPath = "C:/the necessary folder path" 'Use here your real Folder Path!!!
  For i = 1 To UBound(arrKeys)
        If arrKeys(i, 1) <> "" Then
            fileName = Dir(folderPath & "\" & "*" & arrKeys(i, 1) & "*" & key2 & "*.xlsx")
            lastDate = 0
            Do While fileName <> ""
                lastModifDate = CDate(Int(FileDateTime(folderPath & "\" & fileName)))
                If lastModifDate > lastDate Then lastDate = lastModifDate
                fileName = Dir
            Loop
            If lastModifDate <> 0 Then arrDate(i, 1) = lastModifDate: lastModifDate = 0
        End If
  Next i
  
  With sh.Range("G4").Resize(UBound(arrDate), 1)
        .Value2 = arrDate
        .NumberFormat = "dd-mmm-yy"
  End With
End Sub

I need help to find multiple files in multiple unique folders on my network drive and return a date modified to my spreadsheet.

CodePudding user response：

Please, try the next approach. Not tested, but it should be working, I think. Take care to place a ending backslash ("") in the "drivePath" main folder. It assumes that the files to be processed for a specific pair of the two keys should be found in a folder following the next pattern: main_folder\unknown_folder_Name"" & numeric_key & ""\PROOF"" & numeric_key & "" & AlphaNumeric_Key & "*.pdf"

Sub GetFilesDetailsAllFolders()
    Const drivePath As String = "S:\", fileExt As String = "*.pdf"
    Const key1 As String = "PROOF"

    Dim sh As Worksheet, lastR As Long, arrKeys, arrDate, i As Long
    Dim arrF, El, arrFold, strFold As String, boolFound As Boolean
    Dim strGoodFold As String, sFoldCol As New Collection, LastD As Date
    
    Set sh = ActiveSheet 'use here the necessary worksheet
    lastR = sh.Range("B" & sh.rows.count).End(xlUp).Row
  
    arrKeys = sh.Range("B4:B" & lastR).Value2 'place the range in an array for faster iteration
    arrDate = sh.Range("G4:G" & lastR).Value2
    
    arrF = AllFiles(drivePath, fileExt, True) 'build an array of all files having fileExt extension (from all folders and subfolders)!
    
    For i = 1 To UBound(arrKeys)
        If arrKeys(i, 1) <> "" Then
            For Each El In arrF
                If (strGoodFold <> "") And (left(El, InStrRev(El, "\")) <> strGoodFold) Then
                    strGoodFold = "": Exit For 'if iteration passed the appropriate (unique) subfolder...
                End If
                arrFold = Split(Replace(El, drivePath, ""), "\")
                
                If UBound(arrFold) = 3 Then 'process only files full name having 3 subfolders (except drivePath):
                    If arrFold(1) Like "*" & arrKeys(i, 1) & "*" And _
                                arrFold(2) Like key1 And arrFold(3) Like _
                                "*" & arrKeys(i, 1) & "*" & key1 & fileExt Then
                        boolFound = True: strGoodFold = left(El, InStrRev(El, "\")) 'the path to exit the code if not the same folder
                        sFoldCol.Add El          'add the full name in the collection
                    End If
                End If
            Next El
            
            If boolFound Then     'sFoldCol has been loaded with at least one file full path string
                boolFound = False 'reitialize the boolean variable to cnnfirm collection loading
                arrDate(i, 1) = LastModif(sFoldCol): Set sFoldCol = Nothing 'clear the collection
            End If
        End If
    Next i
    'drop the processec array content and format the range as Date:
    With sh.Range("G4").Resize(UBound(arrDate), 1)
        .Value2 = arrDate
        .NumberFormat = "dd-mmm-yy"
    End With
End Sub

It needs the function to return all files full name, from all folders and subfolders of the main one:

Private Function AllFiles(strFold As String, Optional strExt As String = "*.*", Optional boolSubfolders = False) As Variant
    Dim arrFiles, i As Long, lastName As String, lngNb As Long, arrN, El
    'return all files name in an array:
    If boolSubfolders Then 'subfolders included:
        arrFiles = filter(Split(CreateObject("wscript.shell").Exec("cmd /c dir """ & strFold & strExt & """ /b/s").StdOut.ReadAll, vbCrLf), "\")
    Else                         'without subfolders:
        arrFiles = Split(CreateObject("wscript.shell").Exec("cmd /c dir """ & strFold & strExt & """ /b").StdOut.ReadAll, vbCrLf)
        arrFiles = Split(strFold & Join(arrFiles, "|" & strFold), "|")                                'add the folder path to the file names
        arrFiles(UBound(arrFiles)) = "@@##": arrFiles = filter(arrFiles, "@@##", False) 'remove the last (empty) array element
    End If

    AllFiles = arrFiles
End Function

And another one to return the last modified date, for the specific files:

Function LastModif(col As Collection) As Date
   Dim lastModifDate As Date, lastDate As Date, El
   For Each El In col
        lastModifDate = CDate(Int(FileDateTime(El)))
        If lastModifDate > lastDate Then lastDate = lastModifDate
   Next El
  
   If lastModifDate <> 0 Then LastModif = lastModifDate
End Function

Since not tested and I must leave my office now, it may have problems. Or not... I am sure that the logic behind it is OK, but if I missed something, please do not hesitate to explain what problem, what error and on what code line. If the above assumption is not a correct one, please state which to be the basis.

I will be able to see your comment after some hours, when I will be at home...