Поиск файла каталога VBA с использованием списка в Excel

Question

В настоящее время я пытаюсь отредактировать макрос, который использует мой коллега, в настоящее время скрипт открывает окно сообщения, которое позволяет вам вводить строку, которая затем выполняется поиск и результаты вставляются в книгу. Я хотел бы изменить это, чтобы он искал список уже в электронной таблице, а затем для того, чтобы результаты были вставлены на следующем листе. Я не уверен, действительно ли это возможно или нет, и где моя основная борьба. Ниже приведен текущий код, я полагаю, все, что необходимо для переменного диапазона для размещения в том, что звездах «тзд =„Введите имя файла и расширение“

Sub Filesearch() 
Dim myDir As String, temp(), myList, myExtension As String 
    Dim SearchSubFolders As Boolean, Rtn As Integer, msg As String 
    With Application.FileDialog(msoFileDialogFolderPicker) 
     If .Show Then 
      myDir = .SelectedItems(1) 
     End If 
    End With 
    msg = "Enter File name and Extension" & vbLf & "following wild" & _ 
    " cards can be used" & vbLf & "* # ?" 
    myExtension = Application.InputBox(msg) 
    If (myExtension = "False") + (myExtension = "") Then Exit Sub 
    Rtn = MsgBox("Include Sub Folders ?", vbYesNo) 
    SearchSubFolders = Rtn = 6 
    myList = SearchFiles(myDir, myExtension, 0, temp(), SearchSubFolders) 
    If Not IsError(myList) Then 
     Sheets(1).Cells(1).Resize(UBound(myList, 2), 2).Value = _ 
     Application.Transpose(myList) 
    Else 
     MsgBox "No file found" 
    End If 
End Sub 


Private Function SearchFiles(myDir As String _ 
    , myFileName As String, n As Long, myList() _ 
    , Optional SearchSub As Boolean = False) As Variant 
    Dim fso As Object, myFolder As Object, myFile As Object 
    Set fso = CreateObject("Scripting.FileSystemObject") 
    For Each myFile In fso.getfolder(myDir).Files 
     Select Case myFile.Attributes 
     Case 2, 4, 6, 34 
     Case Else 
      If (Not myFile.Name Like "~$*") _ 
      * (myFile.Path & "\" & myFile.Name <> ThisWorkbook.FullName) _ 
      * (UCase(myFile.Name) Like UCase(myFileName)) Then 
       n = n + 1 
       ReDim Preserve myList(1 To 2, 1 To n) 
       myList(1, n) = myDir 
       myList(2, n) = myFile.Name 
      End If 
     End Select 
    Next 
    If SearchSub Then 
     For Each myFolder In fso.getfolder(myDir).subfolders 
      SearchFiles = SearchFiles(myFolder.Path, myFileName, _ 
      n, myList, SearchSub) 
     Next 
    End If 
    SearchFiles = IIf(n > 0, myList, CVErr(xlErrRef)) 
End Function 

Answer 1

Предлагайте использование Defined Name Ranges держать пользователь поддерживается список (как показано на рисунке ниже)

Давайте добавим таблицу для пользователя ввода требований, называемых «_Tables». Затем создайте Defined Name Ranges, для пользователей, чтобы ввести требования, называемого "_Path", "_Files" и "_SubFldrs"

Затем замените все введенные пользователем в текущем коде

REPLACE THIS 
''' With Application.FileDialog(msoFileDialogFolderPicker) 
'''  If .Show Then 
'''   myDir = .SelectedItems(1) 
'''  End If 
''' End With 
''' msg = "Enter File name and Extension" & vbLf & "following wild" & _ 
''' " cards can be used" & vbLf & "* # ?" 
''' myExtension = Application.InputBox(msg) 
''' If (myExtension = "False") + (myExtension = "") Then Exit Sub 
''' Rtn = MsgBox("Include Sub Folders ?", vbYesNo) 
''' SearchSubFolders = Rtn = 6 

с этим для того, чтобы прочитать требования из рабочего листа «_Tables»

Set WshLst = ThisWorkbook.Sheets("_Tables") 
    sPath = WshLst.Range("_Path").Value2 
    aFleKey = WshLst.Range("_Files").Value2 
    bSbFldr = UCase(WshLst.Range("_SubFldrs").Value2) = UCase("YES") 
    aFleKey = WorksheetFunction.Transpose(aFleKey) 

затем обработать списки См. Ниже приведенный ниже код. Это необходимо иметь заявление Option Base 1 в верхней части модуля

Option Explicit 
Option Base 1 

Sub Fle_FileSearch_List() 
Dim WshLst As Worksheet 
Dim sPath As String 
Dim aFleKey As Variant, vFleKey As Variant 
Dim bSbFldr As Boolean 
Dim vFleLst() As Variant 
Dim lN As Long 

    Set WshLst = ThisWorkbook.Sheets("_Tables") 
    sPath = WshLst.Range("_Path").Value2 
    aFleKey = WshLst.Range("_Files").Value2 
    bSbFldr = UCase(WshLst.Range("_SubFldrs").Value2) = UCase("YES") 
    aFleKey = WorksheetFunction.Transpose(aFleKey) 

    Rem To clear output location 
    ThisWorkbook.Sheets(1).Columns(1).Resize(, 2).Clear 

    Rem Process input list 
    For Each vFleKey In aFleKey 
     If (vFleKey <> "False") * (vFleKey <> "") Then 
     Call Fle_FileSearch_Fldrs(sPath, CStr(vFleKey), lN, vFleLst, bSbFldr) 
    End If: Next 

    Rem Validate Results & List Files found 
    If lN > 1 Then 
     ThisWorkbook.Sheets(1).Cells(1).Resize(UBound(vFleLst, 2), 2) _ 
      .Value = Application.Transpose(vFleLst) 
    Else 
     MsgBox "No file found" 
    End If 

End Sub 

Кроме того, некоторые корректировки в функции (теперь процедура) чтобы процесс списка.

Sub Fle_FileSearch_Fldrs(sPath As String, _ 
    sFleKey As String, lN As Long, vFleLst() As Variant, _ 
    Optional bSbFldr As Boolean = False) 

Dim oFso As Object, oFolder As Object, oFile As Object 

    Set oFso = CreateObject("Scripting.FileSystemObject") 

    If lN = 0 Then 
     lN = 1 + lN 
     ReDim Preserve vFleLst(1 To 2, 1 To lN) 
     vFleLst(1, lN) = "Files Found - Path" 
     vFleLst(2, lN) = "Files Found - Name" 
    End If 

    For Each oFile In oFso.GetFolder(sPath).Files 
     Select Case oFile.Attributes 
     Case 2, 4, 6, 34  
     Case Else 
      If (Not oFile.Name Like "~$*") * _ 
       (oFile.Path & "\" & oFile.Name <> ThisWorkbook.FullName) * _ 
       (UCase(oFile.Name) Like UCase(sFleKey)) Then 

       lN = lN + 1 
       ReDim Preserve vFleLst(1 To 2, 1 To lN) 
       vFleLst(1, lN) = sPath 
       vFleLst(2, lN) = oFile.Name 

    End If: End Select: Next 

    If bSbFldr Then 
     For Each oFolder In oFso.GetFolder(sPath).subfolders 
      Call Fle_FileSearch_Fldrs(oFolder.Path, sFleKey, lN, vFleLst, bSbFldr) 
    Next: End If 

End Sub