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一部分，它会告诉你是否值在数组中。