VBA excel 搜索工具

Question

嘗試對我正在處理的 excel 工作表（VBA）進行搜索工具。 到目前為止，每次我搜索文本時，它最終只過濾第一行，而不是任何具有我正在尋找的值的行。 我添加了一張圖片來顯示它返回的內容以及代碼。 我需要更改代碼以使其搜索工作表中的所有數據而不是只顯示一行嗎？ 任何幫助表示贊賞。

僅第一行的搜索結果：

Sub SearchAllSheets()
Dim ws As Worksheet, OutputWs As Worksheet
Dim rFound As Range
Dim strName As String
Dim count As Long, LastRow As Long
Dim IsValueFound As Boolean

IsValueFound = False
Set OutputWs = Worksheets("sheet1")    '---->change the sheet name as required
LastRow = OutputWs.Cells(Rows.count, "A").End(xlUp).Row

On Error Resume Next
strName = InputBox("What are you looking for?")
If strName = "" Then Exit Sub
For Each ws In Worksheets
    If ws.Name <> "Output" Then
        With ws.UsedRange
            Set rFound = .Find(What:=strName, After:=.Cells(1, 1), LookIn:=xlValues, LookAt:=xlWhole)
            If Not rFound Is Nothing Then
                Application.Goto rFound, True
                IsValueFound = True
                'MsgBox rFound.Row
                rFound.EntireRow.Copy
                OutputWs.Cells(LastRow + 1, 1).PasteSpecial xlPasteAll
                Application.CutCopyMode = False
                LastRow = LastRow + 1
            End If
        End With
    End If
Next ws
On Error GoTo 0
If IsValueFound Then
   OutputWs.Select
   MsgBox "Result pasted to Sheet Output"
Else
    MsgBox "Value not found"
End If
End Sub

Answer 1

嘗試這個：

Sub SearchAllSheets()
    
    Dim ws As Worksheet, OutputWs As Worksheet
    Dim rFound As Range, IsValueFound As Boolean
    Dim strName As String
    Dim count As Long, LastRow As Long
    
    Set OutputWs = Worksheets("Output")    '---->change the sheet name as required
    LastRow = OutputWs.Cells(Rows.count, "A").End(xlUp).row
    
    strName = Trim(InputBox("What are you looking for?"))
    If strName = "" Then Exit Sub
    For Each ws In Worksheets
        If ws.Name <> OutputWs.Name Then
            Debug.Print "Checking " & ws.Name
            Set rFound = FindAll(ws.UsedRange, strName)
            If Not rFound Is Nothing Then
                Set rFound = rFound.EntireRow
                count = rFound.Cells.count / Columns.count 'how many matched rows?
                Debug.Print "Found " & count & " rows"
                rFound.Copy OutputWs.Cells(LastRow + 1, 1)
                LastRow = LastRow + count
                IsValueFound = True
            End If
        End If
    Next ws
    
    If IsValueFound Then
       OutputWs.Select
       MsgBox "Result(s) pasted to Sheet " & OutputWs.Name
    Else
        MsgBox "Value not found"
    End If

End Sub

'find all cells in range `rng` with value `val` and return as a range
Public Function FindAll(rng As Range, val As String) As Range
    Dim rv As Range, f As Range
    Dim addr As String
 
    Set f = rng.Find(what:=val, After:=rng.Cells(rng.Cells.count), _
        LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
        SearchDirection:=xlNext, MatchCase:=False)
    If Not f Is Nothing Then addr = f.Address()
    
    Do Until f Is Nothing
        If rv Is Nothing Then
            Set rv = f
        Else
            Set rv = Application.Union(rv, f)
        End If
        Set f = rng.FindNext(After:=f)
        If f.Address() = addr Then Exit Do
    Loop
    Set FindAll = rv
End Function