搜索特定值並復制行以從整個工作簿粘貼到新工作表中

Question

我嘗試了很多代碼並將它們組合起來實現但是這段代碼有問題，我需要幫助。

我希望我的代碼輸入特定單詞（在特定列中）並搜索所有工作表以查找匹配項，然后復制具有相同值的多行並粘貼到一些新工作表中。

謝謝你

這是代碼：

       Dim CountSearchRow As Integer
       Dim CountCopyToRow As Integer
       CountSearchRow = 1
       CountCopyToRow = 2
       Dim sstring As String
       Dim found As Range
       Dim ws As Worksheet
          sstring = InputBox("Please enter a value to search", "Enter value")

        For Each Sh In ThisWorkbook.Sheets
           With Sh.UsedRange
            Set found = .Find(What:=sstring, LookIn:=xlValues, LookAt:=xlWhole, _
            SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)

            Rows(CStr(CountSearchRow) & ":" & CStr(CountSearchRow)).Select
            Selection.Copy

            Sheets("Sheet2").Select
            Rows(CStr(CountCopyToRow) & ":" & CStr(CountCopyToRow)).Select
            ActiveSheet.Paste

            CountCopyToRow = CountCopyToRow + 1         
    End With
    Next
    End Sub

Answer 1

Sub FindAndCopyRowsAllSheets()
Dim ws As Worksheet, wsRng As Range, sstr As String, txt As String
Dim foundRng As Range, tempRng As Range, caseSense As Boolean
CountCopyToRow = 2

caseMsg = MsgBox("Make this search CASE-sensitive?", _
            vbYesNoCancel)
If caseMsg = vbYes Then
    caseSense = True
    Else
        If caseMsg = vbNo Then
            caseSense = False
            Else
            Exit Sub
        End If
End If

If caseSense = True Then
    txt = "Enter the value to search" & vbCrLf & vbCrLf & _
    "Search is CASE-Sensitve"
    Else
    txt = "Enter the value to search" & vbCrLf & vbCrLf & _
    "Search is NOT case-sensitve"
End If

sstr = InputBox(txt, "Search Value")
If sstr = "" Then Exit Sub

'If you want to search all the sheets for sstr _
loop through all the sheets like below. _
Or you can remove this loop and _
set ws = the sheet to be searched in

For Each ws In ThisWorkbook.Worksheets
    If ws.Name <> "Sheet2" Then
        Set wsRng = ws.Range(ws.Range("A1"), _
            ws.Range("A1").SpecialCells(xlLastCell))
        Set tempRng = ws.Cells(wsRng.Rows.Count, wsRng.Columns.Count)
    For Each Row In wsRng.Rows
    If foundRng Is Nothing Then
        Set tempRng = wsRng.Find(What:=sstr, After:=tempRng, _
        LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _
        SearchDirection:=xlNext, MatchCase:= _
        caseSense, SearchFormat:=False)
        If Not tempRng Is Nothing Then
            Set foundRng = tempRng.EntireRow
            Else
            Exit For
        End If
    Else
        Set tempRng = wsRng.Find(What:=sstr, After:=tempRng, _
        LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _
        SearchDirection:=xlNext, MatchCase:= _
        caseSense, SearchFormat:=False)

        If Not Intersect(foundRng, tempRng) Is Nothing Then Exit For
        Set foundRng = Union(foundRng, tempRng.EntireRow)
    End If
        Sheets("Sheet2").Rows(CountCopyToRow).Value = _
                        tempRng.EntireRow.Value
        CountCopyToRow = CountCopyToRow + 1
    Next Row
    End If
    Set tempRng = Nothing
    Set foundRng = Nothing
Next ws

End Sub

Answer 2

我猜您可能會在對代碼進行此修訂后：

Dim CountCopyToRow As Long
CountCopyToRow = 2
Dim sstring As String
Dim found As Range
Dim ws As Worksheet

sstring = InputBox("Please enter a value to search", "Enter value")

For Each ws In ThisWorkbook.Worksheets
    If ws.Name <> "Sheet2" Then ' don't search in "Sheet2" sheet
        With ws
            Set found = .UsedRange.Find(What:=sstring, LookIn:=xlValues, LookAt:=xlWhole, _
            SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)

            If Not found Is Nothing Then ' if found
                found.EntireRow.Copy Destination:=Sheets("Sheet2").Rows(CountCopyToRow)
                CountCopyToRow = CountCopyToRow + 1
            End If
        End With
    End If
Next