Excelでの検索ツール

Question

私はExcel VBAの初心者です。私のコードを拡張するには本当に助けが必要です。 コードは、すべてのワークシートのテキストを検索します。 すべての検索結果を、テキストが見つかる完全な行の最初のシートに記載したいと思います。残念ながら、基準が見つかった行をコピーする方法がわかりません。 もし私がコードを検査するための解決策を得ることができれば、大きな助けになるでしょう。コードの下

Sub SearchAllSheets() 

Dim ws As Worksheet 
Dim rFound As Range 
Dim strName As String 

    On Error Resume Next 
    strName = InputBox("What are you looking for?") 
    If strName = "" Then Exit Sub 
    For Each ws In Worksheets 
     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 
       Exit Sub 
      End If 
     End With 
    Next ws 
    On Error GoTo 0 

    MsgBox "Value not found" 

End Subの

Answer 1

すべてのシートのすべての出現をテキストで検索したいと思っています。このコードを試してみてください。

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

    IsValueFound = False 
    Set OutputWs = Worksheets("Output") '---->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 
        FirstAddress = rFound.Address 

        Do 
         Application.Goto rFound, True 
         IsValueFound = True 
         'MsgBox rFound.Row 
         Debug.Print rFound.Address 

         rFound.EntireRow.Copy 
         OutputWs.Cells(LastRow + 1, 1).PasteSpecial xlPasteAll 
         Application.CutCopyMode = False 
         LastRow = LastRow + 1 

         Set rFound = .FindNext(rFound) 
        Loop While Not rFound Is Nothing And rFound.Address <> FirstAddress 

       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 2

シートOutputに検出されたデータを持つ行を貼り付けます。コードは結果のためにOutputシートを検索しません。

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("Output") '---->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