如何结束这个循环？

我现在有一个VBA代码，要求用户input一个string以及某个目录，然后search每个文件夹，子文件夹，工作簿和工作表，直到find用户放入的string。运行到它发现string后，它继续search其余的文件夹。 我将使用这个应用程序，只有一个被search的string。 我已经尝试debugging，并使用与“c”if语句来匹配str，但它一直抛出一个错误。 代码附在下面，任何帮助表示赞赏。

Public WS As Worksheet Sub SearchWKBooksSubFolders(Optional Folderpath As Variant, Optional Str As Variant) Dim myfolder As String Dim a As Single Dim sht As Worksheet Dim Lrow As Single Dim Folders() As String Dim Folder As Variant ReDim Folders(0) If IsMissing(Folderpath) Then Set WS = Sheets.Add With Application.FileDialog(msoFileDialogFolderPicker) .Show myfolder = .SelectedItems(1) & "\" End With Str = Application.InputBox(prompt:="Search string:", Title:="Search all workbooks in a folder", Type:=2) If Str = "" Then Exit Sub WS.Range("A1") = "Search string:" WS.Range("B1") = Str WS.Range("A2") = "Path:" WS.Range("B2") = myfolder WS.Range("A3") = "Folderpath" WS.Range("B3") = "Workbook" WS.Range("C3") = "Worksheet" WS.Range("D3") = "Cell Address" WS.Range("E3") = "Link" Folderpath = myfolder Value = Dir(myfolder, &H1F) Else If Right(Folderpath, 2) = "\\" Then Exit Sub End If Value = Dir(Folderpath, &H1F) End If Do Until Value = "" If Value = "." Or Value = ".." Then Else If GetAttr(Folderpath & Value) = 16 Then Folders(UBound(Folders)) = Value ReDim Preserve Folders(UBound(Folders) + 1) ElseIf (Right(Value, 3) = "xls" Or Right(Value, 4) = "xlsx" Or Right(Value, 4) = "xlsm") And Left(Value, 1) <> "~" Then On Error Resume Next Dim wb As Workbook Set wb = Workbooks.Open(Filename:=Folderpath & Value, Password:="zzzzzzzzzzzz") On Error GoTo 0 'If there is an error on Workbooks.Open, then wb Is Nothing: If wb Is Nothing Then Lrow = WS.Range("A" & Rows.Count).End(xlUp).Row + 1 WS.Range("A" & Lrow).Value = Value WS.Range("B" & Lrow).Value = "Password protected" Else For Each sht In wb.Worksheets 'Expand all groups in sheet sht.Unprotect sht.Outline.ShowLevels RowLevels:=8, ColumnLevels:=8 Set c = sht.Cells.Find(Str, After:=sht.Cells(1, 1), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext) If Not c Is Nothing Then firstAddress = c.Address Do Lrow = WS.Range("A" & Rows.Count).End(xlUp).Row + 1 WS.Range("A" & Lrow).Value = Folderpath WS.Range("B" & Lrow).Value = Value WS.Range("C" & Lrow).Value = sht.Name WS.Range("D" & Lrow).Value = c.Address WS.Hyperlinks.Add Anchor:=WS.Range("E" & Lrow), Address:=Folderpath & Value, SubAddress:= _ "'" & sht.Name & "'" & "!" & c.Address, TextToDisplay:="Link" Set c = sht.Cells.FindNext(After:=c) Loop While Not c Is Nothing And c.Address <> firstAddress End If Next sht wb.Close False End If End If End If Value = Dir Loop For Each Folder In Folders Call SearchWKBooksSubFolders(Folderpath & Folder & "\", Str) Next Folder Cells.EntireColumn.AutoFit End Sub 

Answer 1

添加一个你设置为True的布尔variables来表明你已经find了你要找的东西。 像这样的东西：

 Sub SearchWKBooksSubFolders(Optional Folderpath As Variant, Optional Str As Variant) Dim myfolder As String Dim a As Single Dim sht As Worksheet Dim Lrow As Single Dim Folders() As String Dim Folder As Variant ReDim Folders(0) If IsMissing(Folderpath) Then Set WS = Sheets.Add With Application.FileDialog(msoFileDialogFolderPicker) .Show myfolder = .SelectedItems(1) & "\" End With Str = Application.InputBox(prompt:="Search string:", Title:="Search all workbooks in a folder", Type:=2) If Str = "" Then Exit Sub WS.Range("A1") = "Search string:" WS.Range("B1") = Str WS.Range("A2") = "Path:" WS.Range("B2") = myfolder WS.Range("A3") = "Folderpath" WS.Range("B3") = "Workbook" WS.Range("C3") = "Worksheet" WS.Range("D3") = "Cell Address" WS.Range("E3") = "Link" Folderpath = myfolder value = Dir(myfolder, &H1F) Else If Right(Folderpath, 2) = "\\" Then Exit Sub End If value = Dir(Folderpath, &H1F) End If '---Add this: Dim TimeToStop As Boolean '---Change this: Do Until TimeToStop If value = "." Or value = ".." Then Else If GetAttr(Folderpath & value) = 16 Then Folders(UBound(Folders)) = value ReDim Preserve Folders(UBound(Folders) + 1) ElseIf (Right(value, 3) = "xls" Or Right(value, 4) = "xlsx" Or Right(value, 4) = "xlsm") And Left(value, 1) <> "~" Then On Error Resume Next Dim wb As Workbook Set wb = Workbooks.Open(fileName:=Folderpath & value, Password:="zzzzzzzzzzzz") On Error GoTo 0 'If there is an error on Workbooks.Open, then wb Is Nothing: If wb Is Nothing Then Lrow = WS.Range("A" & Rows.Count).End(xlUp).Row + 1 WS.Range("A" & Lrow).value = value WS.Range("B" & Lrow).value = "Password protected" Else For Each sht In wb.Worksheets 'Expand all groups in sheet sht.Unprotect sht.Outline.ShowLevels RowLevels:=8, ColumnLevels:=8 Set c = sht.Cells.Find(Str, After:=sht.Cells(1, 1), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext) If Not c Is Nothing Then '---Add this TimeToStop = True 'since we found what we're looking for firstAddress = c.Address Do Lrow = WS.Range("A" & Rows.Count).End(xlUp).Row + 1 WS.Range("A" & Lrow).value = Folderpath WS.Range("B" & Lrow).value = value WS.Range("C" & Lrow).value = sht.Name WS.Range("D" & Lrow).value = c.Address WS.Hyperlinks.Add Anchor:=WS.Range("E" & Lrow), Address:=Folderpath & value, SubAddress:= _ "'" & sht.Name & "'" & "!" & c.Address, TextToDisplay:="Link" Set c = sht.Cells.FindNext(After:=c) Loop While Not c Is Nothing And c.Address <> firstAddress End If Next sht wb.Close False End If End If End If value = Dir '---Add these 3 lines If Len(value) = 0 Then TimeToStop = True End If Loop For Each Folder In Folders Call SearchWKBooksSubFolders(Folderpath & Folder & "\", Str) Next Folder Cells.EntireColumn.AutoFit End Sub 

请注意，你正在recursion地调用你的例程：

  For Each Folder In Folders Call SearchWKBooksSubFolders(Folderpath & Folder & "\", Str) Next Folder 

一旦你完成了所有的search程序，你将重新开始，因为你在你的Sub调用你的Sub 。 不知道这是否是你以后的事情，这可能是进一步意外循环的另一个原因。

Answer 2

“如果Str = c.Value Then GoTo 85”

改成

“如果Str = c.Value Then End”