excel - 使用具有多个搜索变量的 VBA 搜索多个 Excel 文件并输出到一张纸/CSV

Question

我正在尝试修改此代码，以从包含多个 excel 文件的文件夹中搜索多个值，并将其输出到工作表或 CSV。

该代码能够搜索多个excel表并输出值，但问题是它只输出第一个搜索值“ search_a ”。

该代码在文件夹中搜索该值并将其放入新工作表中。

它给出了 search_a 的搜索结果，但没有给出其他 search_b、search_c 的搜索结果......所有搜索结果都应该在一张纸上。

我知道我犯了一些简单的错误，但我无法识别它。

我还尝试从 .txt 文件列表中导入搜索值，但这不起作用。

Sub SearchFolders()
    Dim xFso As Object
    Dim xFld As Object
    Dim xStrSearch As Variant
    Dim xStrPath As String
    Dim xStrFile As String
    Dim xOut As Worksheet
    Dim xWb As Workbook
    Dim xWk As Worksheet
    Dim xRow As Long
    Dim xFound As Range
    Dim xStrAddress As String
    Dim xFileDialog As FileDialog
    Dim xUpdate As Boolean
    Dim xCount As Long
    Dim xStrS As Variant
    On Error GoTo ErrHandler

    Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
    xFileDialog.AllowMultiSelect = False
    xFileDialog.Title = "Select a forlder"
    If xFileDialog.Show = -1 Then
        xStrPath = xFileDialog.SelectedItems(1)
    End If
    If xStrPath = "" Then Exit Sub


    xUpdate = Application.ScreenUpdating
    Application.ScreenUpdating = False
    Set xOut = Worksheets.Add
    xRow = 1
    With xOut
        .Cells(xRow, 1) = "Workbook"
        .Cells(xRow, 2) = "Worksheet"
        .Cells(xRow, 3) = "Cell"
        .Cells(xRow, 4) = "Text in Cell"
        Set xFso = CreateObject("Scripting.FileSystemObject")
        Set xFld = xFso.GetFolder(xStrPath)
        xStrFile = Dir(xStrPath & "\*.xls*")

        xStrSearch = Array("search_a", "search_b", "search_c", "search_d", "search_e", "search_f")
        For Each xStrS In xStrSearch

        Do While xStrFile <> ""
            Set xWb = Workbooks.Open(Filename:=xStrPath & "\" & xStrFile, UpdateLinks:=0, ReadOnly:=True, AddToMRU:=False)
            For Each xWk In xWb.Worksheets
                Set xFound = xWk.UsedRange.Find(xStrSearch)
                If Not xFound Is Nothing Then
                    xStrAddress = xFound.Address
                End If
                Do
                    If xFound Is Nothing Then
                        Exit Do
                    Else
                        xCount = xCount + 1
                        xRow = xRow + 1
                        .Cells(xRow, 1) = xWb.Name
                        .Cells(xRow, 2) = xWk.Name
                        .Cells(xRow, 3) = xFound.Address
                        .Cells(xRow, 4) = xFound.Value
                    End If
                    Set xFound = xWk.Cells.FindNext(After:=xFound)
                Loop While xStrAddress <> xFound.Address
            Next
            xWb.Close (False)
            xStrFile = Dir
        Loop
        Next
        .Columns("A:D").EntireColumn.AutoFit
    End With

ExitHandler:
    Set xOut = Nothing
    Set xWk = Nothing
    Set xWb = Nothing
    Set xFld = Nothing
    Set xFso = Nothing
    Application.ScreenUpdating = xUpdate
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler

End Sub

我想要一张表或 csv 中所有搜索值的搜索结果。

标签： excelvba

Answer 1

我无法完全测试我的代码，但从我所做的小测试来看，它似乎有效：

Option Explicit

Private Function GetFolderPath(ByRef folderPathSelected As String) As Boolean
    Dim xFileDialog As FileDialog
    Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)

    xFileDialog.AllowMultiSelect = False
    xFileDialog.Title = "Select a folder"
    If xFileDialog.Show = -1 Then
        folderPathSelected = xFileDialog.SelectedItems(1)
        GetFolderPath = True
    End If
End Function

Private Function GetAllExcelFilesInFolder(ByVal someFolderPath As String, Optional ByVal dirCriteria As String = "*.xls*") As Collection
     ' Could probably use FileSystemObject instead for this.
     Dim outputCollection As Collection
     Set outputCollection = New Collection

     If Right$(someFolderPath, 1) <> "\" Then
        someFolderPath = someFolderPath & "\"
     End If

     Dim Filename As String
     Filename = Dir$(someFolderPath & dirCriteria)

     Do Until Len(Filename) = 0
        outputCollection.Add someFolderPath & Filename
        Filename = Dir$()
     Loop

     Set GetAllExcelFilesInFolder = outputCollection
End Function

Private Function MaybeUnion(ByVal firstRange As Range, ByVal secondRange As Range) As Range
    ' Assumes firstRange is good (and doesn't need checking).
    If Not (secondRange Is Nothing) Then
        Set MaybeUnion = Union(firstRange, secondRange)
    Else
        Set MaybeUnion = firstRange
    End If
End Function

Private Function FindAllInWorkbook(ByVal someWorkbook As Workbook, _
                                    ByVal What As String, _
                                    Optional ByVal LookIn As XlFindLookIn = xlValues, _
                                    Optional ByVal LookAt As XlLookAt = xlWhole, _
                                    Optional SearchOrder As XlSearchOrder = xlByRows, _
                                    Optional SearchDirection As XlSearchDirection = xlNext, _
                                    Optional ByVal MatchCase As Boolean = False) As Range
    Dim outputRange As Range

    Dim targetSheet As Worksheet
    For Each targetSheet In someWorkbook.Worksheets
        Dim cellFound As Range
        Set cellFound = targetSheet.Cells.Find(What, , LookIn, LookAt, LookAt, SearchOrder, SearchDirection, MatchCase)

        If Not (cellFound Is Nothing) Then
            Dim addressOfFirstMatch As String
            addressOfFirstMatch = cellFound.Address
            Do
                Set outputRange = MaybeUnion(cellFound, outputRange)
                Set cellFound = targetSheet.Cells.FindNext(After:=cellFound)
            Loop Until cellFound.Address = addressOfFirstMatch
        End If
    Next targetSheet
    Set FindAllInWorkbook = outputRange
End Function

Private Sub FindStringsInWorkbooks()
    Dim folderPath As String
    If Not GetFolderPath(folderPath) Then Exit Sub

    Dim filePathsToProcess As Collection
    Set filePathsToProcess = GetAllExcelFilesInFolder(folderPath)

    Dim stringsToSearchFor As Variant
    stringsToSearchFor = Array("search_a", "search_b", "search_c", "search_d", "search_e", "search_f")

    Dim outputSheet As Worksheet
    Set outputSheet = ThisWorkbook.Worksheets.Add
    outputSheet.Range("A1:D1") = Array("Workbook", "Worksheet", "Cell", "Text in Cell")

    Dim outputRowIndex As Long
    outputRowIndex = 1 ' Skip header row

    Dim filePath As Variant
    For Each filePath In filePathsToProcess
        Dim targetBook As Workbook
        Set targetBook = Application.Workbooks.Open(Filename:=filePath, UpdateLinks:=0, ReadOnly:=True, AddToMRU:=False)

        Dim stringToFind As Variant
        For Each stringToFind In stringsToSearchFor
            Dim cellsFound As Range
            Set cellsFound = FindAllInWorkbook(targetBook, stringToFind, xlValues, xlWhole, xlByRows, xlNext, False)
            If Not (cellsFound Is Nothing) Then
                Dim cell As Range
                For Each cell In cellsFound
                    outputRowIndex = outputRowIndex + 1
                    With outputSheet
                        .Cells(outputRowIndex, "A") = targetBook.Name
                        .Cells(outputRowIndex, "B") = cell.Parent.Name
                        .Cells(outputRowIndex, "C") = cell.Address
                        .Cells(outputRowIndex, "D") = cell.Value
                    End With
                Next cell
            Else
                Debug.Print "No results found for '" & stringToFind & "' in workbook '" & targetBook.Name & "'."
            End If
        Next stringToFind
        targetBook.Close SaveChanges:=False
    Next filePath
End Sub

如果想要：

• 最好利用代码中的函数/过程，这样代码更容易阅读。
• 由于您没有对循环内的工作簿/工作表进行更改，因此您可以先返回所有匹配项，然后再完全处理它们（而不是在找到它们时处理它们）。
• 我认为将工作簿循环放在外部，将搜索词循环放在内部是有意义的。否则，您将打开和关闭相同的工作簿N时间（N您有多少搜索词）。但是，这确实意味着输出/结果的顺序会有所不同。
• 您可能需要重新实现格式设置（例如自动调整列宽等）——并Application.ScreenUpdating根据需要进行切换。