Question

我目前编写了一个VBA代码，要求用户输入字符串以及某个目录，并搜索每个文件夹，子文件夹，工作簿和工作表，直到找到用户输入的字符串。问题我遇到的是，在找到字符串后，它会继续搜索其余的文件夹。应用程序我将使用它，只搜索该字符串中的一个。我尝试过调试，并在＆＃34; c＆＃34;中使用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的布尔变量，表示您已找到要查找的内容。像这样：

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。不知道这是否是你所追求的，它可能是进一步意外循环的另一个原因。

Answer 2

＆＃34;如果Str = c.Value则GoTo 85＆＃34;

更改为

＆＃34;如果Str = c.Value则结束＆＃34;

如何结束这个循环？

2 个答案: