Question

我目前有一个庞大的文件夹，其中包含许多包含Excel工作簿的文件夹中的文件夹。我想要一个用户输入来询问一串数字（例如：405599）并搜索每个文件夹，子文件夹，工作簿，工作表并提供该文件的链接或位置。这是当前的代码，但它似乎陷入搜索第一个文档的第一行然后崩溃。

enter image description here

＆＃13;

   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

＆＃13;

Answer 1

这应该改进错误处理程序，这可能会导致问题，因为它没有正确确定范围。

我已将Find和FindNext都更改为使用After参数，否则您可能会收到一些意外结果。每the documentation（强调添加）：

之后：=您要搜索的单元格。这对应于从用户界面进行搜索时活动单元的位置。请注意，After必须是范围内的单个单元格。请记住，搜索在此单元格之后开始;在方法回绕到此单元格之前，不会搜索指定的单元格。 如果未指定此参数，搜索将在范围左上角的单元格后开始。

另外，我不确定为什么你在a出现错误而不是仅仅使用LRow计算。我也做了那个改变。

在我注意'##### BREAK here and step through code using F8的下面的行上放置一个断点，然后使用 F8 逐行逐步执行代码以确认此方法是否正常工作。确认后，删除断点，您可以允许代码运行完成。

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 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.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

这似乎对我有效：

关于子文件夹的问题，当你以递归方式调用此过程时，你不将可选的 Str参数传递给递归调用。因此，对于子文件夹，该函数正在搜索空Variant类型，它在许多单元格中找到它！

变化：

SearchWKBooksSubFolders (Folderpath & Folder & "\")

要：

Call SearchWKBooksSubFolders(Folderpath & Folder & "\", Str)

如何在Excel VBA中的文件夹和子文件夹中搜索excel工作簿以查找特定的文本字符串

1 个答案: