Как закончить этот цикл?

В настоящее время у меня есть код VBA, написанный для запроса ввода пользователем строки, а также определенного каталога, и он просматривает каждую папку, подпапку, рабочую книгу и рабочие листы, пока не найдет строку, в которую пользователь вложил. что после поиска строки она продолжает искать остальные папки. Приложение, в котором я буду использовать это, есть только одна из этой строки, которую вы ищете. Я попробовал отладку и использовал оператор if с «c» для соответствия 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 

Добавьте логическую переменную, установленную в True чтобы указать, что вы нашли то, что ищете. Что-то вроде этого:

 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 

Помните, что вы рекурсивно называете свою рутинную процедуру:

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

После того, как вы пройдете всю свою поисковую процедуру, вы начнете все заново, потому что вы вызываете свой Sub из своего Sub . Не знаю, является ли это то, что вам нужно, и это может быть дополнительной причиной дальнейшего неожиданного цикла.

«Если Str = c.Value Then GoTo 85"

Изменить на

«Если Str = c.Value Then End»

Давайте будем гением компьютера.