VBA – search除了一个特定的工作簿之外的目录中的所有工作簿？

我正在使用下面的代码来search目录中的所有工作簿：

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

解决这个问题的一个好方法是做以下工作：

– 创build一个所有被忽略列表的数组;

– ws.Name的值是否存在于这个数组中。 如果不存在，则执行该操作;

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

创buildstring数组并检查值是否在这个数组中的想法可以在这里看到：

 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部分，它会显示数值是否在数组中。