VBA - 在一個特定工作簿以外的目錄中搜索所有工作簿？

Question

我使用下面的代碼來搜索所有工作簿中的目錄：

Option Explicit 

Sub Search() 

Dim myFolder As Folder 
Dim fso As FileSystemObject 
Dim destPath As String 
Dim myClient As String 

myClient = ThisWorkbook.ActiveSheet.Range("J10").Value 

If myClient = "" Then Exit Sub 

Set fso = New FileSystemObject 

destPath = "G:\WH DISPO\(3) PROMOTIONS\(18) Food Specials Delivery Tracking\Archive\" 

Set myFolder = fso.GetFolder(destPath) 



'Set extension as you would like 
Call RecurseSubfolders(myFolder, ".xlsm", myClient) 

End Sub 


Sub RecurseSubfolders(ByRef FolderToSearch As Folder, _ 
      ByVal fileExtension As String, ByVal myClient As String) 


Dim app As New Excel.Application 
app.Visible = False 'Visible is False by default, so this isn't necessary 
Application.ScreenUpdating = False 
Application.DisplayAlerts = False 
Application.EnableEvents = False 

Dim fileCount As Integer, folderCount As Integer 
Dim objFile As File 
Dim objSubfolder As Folder 

fileCount = FolderToSearch.Files.Count 
'Loop over all files in the folder, and check the file extension 
If fileCount > 0 Then 
    For Each objFile In FolderToSearch.Files 
    If LCase(Right(objFile.Path, Len(fileExtension))) = LCase(fileExtension) And objFile.Path Like "temp" Then 
     'You can check against "objFile.Type" instead of the extension string, 
     'but you would need to check what the file type to seach for is 
     Call LookForClient(objFile.Path, myClient) 
    End If 
    Next objFile 
End If 

folderCount = FolderToSearch.SubFolders.Count 
'Loop over all subfolders within the folder, and recursively call this sub 
If folderCount > 0 Then 
    For Each objSubfolder In FolderToSearch.SubFolders 
    Call RecurseSubfolders(objSubfolder, fileExtension, myClient) 
    Next objSubfolder 
End If 

End Sub 


Sub LookForClient(ByVal sFilePath As String, ByVal myClient As String) 

Application.ScreenUpdating = False 
Application.DisplayAlerts = False 
Application.EnableEvents = False 

Dim wbTarget As Workbook 
Dim ws As Worksheet 
Dim rngFound As Range 
Dim firstAddress As String 
Static i As Long   'Static ensures it remembers the value over subsequent calls 

'Set to whatever value you want 
If i <= 0 Then i = 20 

Set wbTarget = Workbooks.Open(fileName:=sFilePath) 'Set any other workbook opening variables as appropriate 
'On Error Resume Next 
'Loop over all worksheets in the target workbook looking for myClient 
For Each ws In wbTarget.Worksheets 


    With ws.Range("A:Q") 
    Set rngFound = .Find(What:=myClient, LookIn:=xlValues, LookAt:=xlPart) 

    If Not rngFound Is Nothing Then 
     firstAddress = rngFound.Address 

     'Loop finds all instances of myClient in the range A:Q 
     Do 
     'Reference the appropriate output worksheet fully, don't use ActiveWorksheet 
     ThisWorkbook.ActiveSheet.Range("E" & i).Value = rngFound.Value 
     ThisWorkbook.ActiveSheet.Range("J" & i).Value = rngFound.Address 
     ThisWorkbook.ActiveSheet.Range("L" & i).Value = rngFound.Parent.Parent.Name 

     With ThisWorkbook.Worksheets(1) 
     .Hyperlinks.Add Anchor:=.Range("P" & i), _ 
     Address:=Application.Workbooks(rngFound.Parent.Parent.Name).Path & "\" & rngFound.Parent.Parent.Name, _ 
     ScreenTip:="Open Workbook", _ 
     TextToDisplay:=Application.Workbooks(rngFound.Parent.Parent.Name).Path & "\" & rngFound.Parent.Parent.Name 
     End With 

     ThisWorkbook.ActiveSheet.Range("Y" & i).Value = "Go to Cell" 
     ThisWorkbook.ActiveSheet.Range("Y" & i).Font.Underline = True 



     i = i + 1 
     Set rngFound = .FindNext(After:=rngFound) 
     Loop While (Not rngFound Is Nothing And rngFound.Address <> firstAddress) 
    End If 
    End With 

Next ws 

'Close the workbook 
wbTarget.Close SaveChanges:=False 

Application.ScreenUpdating = True 
Application.DisplayAlerts = True 
Application.EnableEvents = True 
End Sub 

我要排除一個工作簿「temp.xlsm」。

我想這一點：

If LCase(Right(objFile.Path, Len(fileExtension))) = LCase(fileExtension) And objFile <> "temp.xlsm" Then 

但這似乎並沒有工作。我沒有得到任何結果，代碼不會產生錯誤。

請有人能告訴我我要去哪裏嗎？

Answer 1

一個好辦法來解決這個問題是要做到以下幾點：

- 製作全部忽略列表的數組;如果ws.Name的值存在於此數組中，如果它不存在，則執行該操作;

If not fnBlnValueInArray(ws.Name, arrayOfAllIgnoredLists,True) 
     'do your stuff 
end if 

創建字符串數組，並檢查該值是否是該數組中可以看到這裏的想法：

Option Explicit 

Public Function fnBlnValueInArray(myValue As Variant, _ 
            myArray As Variant, _ 
            Optional blnIsString As Boolean = False, _ 
            Optional strSeparator As String = ":") As Boolean 

    Dim lngCounter As Long 

    If blnIsString Then 
     myArray = Split(myArray, strSeparator) 
    End If 

    For lngCounter = LBound(myArray) To UBound(myArray) 
     myArray(lngCounter) = CStr(myArray(lngCounter)) 
    Next lngCounter 

    fnBlnValueInArray = Not IsError(Application.Match(CStr(myValue), myArray, 0)) 

End Function 


Public Sub TestMe() 

    Dim myStrArray As String 
    Dim myArray  As Variant 
    Dim myValue1 As Variant 
    Dim myValue2 As Variant 
    Dim myValue3 As Variant 

    myValue1 = "the" 
    myValue2 = "lazyashell" 
    myValue3 = 42 

    myArray = Array("the", "quick", "brown", "fox", 32, 32, 33, 42) 
    myStrArray = "the:quick:brown:fox:334:33:42" 

    Debug.Print fnBlnValueInArray(myValue1, myArray, False) 
    Debug.Print fnBlnValueInArray(myValue2, myArray, False) 
    Debug.Print fnBlnValueInArray(myValue3, myArray, False) 

    Debug.Print fnBlnValueInArray(myValue1, myStrArray, True, ":") 
    Debug.Print fnBlnValueInArray(myValue2, myStrArray, True) 
    Debug.Print fnBlnValueInArray(myValue3, myStrArray, True) 

End Sub 

運行代碼的TestMe一部分，它會告訴你是否值在數組中。