如何使用两个关键字和 return 电子表格的修改日期信息在我的网络驱动器上的唯一文件夹中搜索文件？

Question

我以不同的方式问过这个问题，但这是在网络驱动器上的单个文件夹中查找文件的答案。

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

我需要帮助才能在我的网络驱动器上的多个唯一文件夹中找到多个文件，并且return我的电子表格的修改日期。

Answer 1

请尝试下一个方法。未经测试，但我认为它应该有效。注意在“drivePath”主文件夹中放置一个结束反斜杠 ("")。它假定要为两个密钥中的特定对处理的文件应该在遵循下一个模式的文件夹中找到：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

它需要 return 所有文件全名的功能，来自主要文件的所有文件夹和子文件夹：

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

还有一个 return 最后修改日期，针对特定文件：

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

由于没有测试，我现在必须离开我的办公室，它可能有问题。或者不是......我确信它背后的逻辑是好的，但如果我遗漏了什么，请不要犹豫解释什么问题，什么错误以及在什么代码行。如果上述假设不正确，请说明以哪一个为基础。

我会在几个小时后看到你的评论，那时我会在家...

如何使用两个关键字和 return 电子表格的修改日期信息在我的网络驱动器上的唯一文件夹中搜索文件？

How do I search for files in unique folders on my network drive using two keywords, and return date modified information to my spreadsheet?

excel

vba