Excel 如何在文件中查找字符串，关闭文件并循环到文件夹中的下一个文件？

我想在文件夹中的所有.xlsx文件中循环查找字符串

如果找到，将文件名、单元格地址、单元格中的文本写入文件，然后关闭该文件并移动到文件夹中的下一个文件

该文件未格式化且已合并单元格

下面的代码部分起作用。问题是，如果在文件中找不到字符串，该文件将保持打开状态，并且不会循环到下一个文件

Sub StringSearch()

    Dim lRow            As Long
    Dim oFile           As Object
    Dim oFiles          As Object
    Dim oFolder         As Object
    Dim rFound          As Range
    Dim rSearch         As Range
    Dim strFirstAddress As String
    Dim strSearch       As String
    Dim vPath           As Variant
    Dim wbk             As Workbook
    Dim wks             As Worksheet
    Dim wOut            As Worksheet

        Application.ScreenUpdating = False

        vPath = ThisWorkbook.Worksheets("Sheet1").Range("B3").Value
        strSearch = ThisWorkbook.Worksheets("Sheet1").Range("D3").Value

        With CreateObject("Shell.Application")
            Set oFolder = .Namespace(vPath)
                If oFolder Is Nothing Then
                    MsgBox "The folder """ & vPath & """ was Not Found.", vbExclamation
                    Exit Sub
                End If
            Set oFiles = oFolder.Items
            ' // Open only xls, xlsx, and xlsm workbooks
            oFiles.Filter 64, "*.xls;*.xlsx;*.xlsm"
        End With

        Set wOut = Worksheets.Add
        lRow = 1

        ' // Add row headers to the new worksheet.
        wOut.Range("A1:D1").Value = Array("Workbook", "Worksheet", "Cell", "Text in Cell")

        For Each oFile In oFiles
            Set wbk = Workbooks.Open _
                (Filename:=oFile.Path, _
                 UpdateLinks:=0, _
                 ReadOnly:=True, _
                 AddToMRU:=False)

            For Each wks In wbk.Worksheets
                Set rSearch = wks.UsedRange
                Set rFound = rSearch.Find(strSearch)
                If rFound Is Nothing Then Exit Sub

                strFirstAddress = rFound.Address

                Do
                    lRow = lRow + 1
                    wOut.Cells(lRow, "A").Resize(1, 4).Value = Array(wbk.Name, wks.Name, rFound.Address, Split(rFound.Value, "P")(0))

                    Set rFound = wks.Cells.FindNext(rFound)
                    If rFound Is Nothing Then Exit Do
                    If rFound.Address = strFirstAddress Then Exit Do
                Loop
            Next wks

            wOut.Columns("A:D").EntireColumn.AutoFit
            wbk.Close SaveChanges:=False
        Next oFile

        MsgBox "Done"

        Application.ScreenUpdating = True

End Sub

---

只需更改

如果rFound为Nothing，则退出Sub

到

如果rFound为Nothing，则退出
，并在
循环
行后添加
End If
。非常感谢您的快速响应。这成功了！