Excel VBA搜索特定值和复制行以从整个工作簿粘贴到新工作表中

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 SlectCond()
Dim ws As Worksheet
Dim wsRng As Range, sstring As String, cell As Range
Dim foundRng As Range, foundAdd As New Collection
Dim tempRng As Range
CountCopyToRow = 2
sstring = InputBox("Enter the value to search", "Search Value")
If sstring = "" Then Exit Sub
Set ws = Sheets("Sheet1")
ws.Activate
ws.Range("A1").Activate
Set wsRng = ws.Range(ws.Range("A1"), _
    ws.Range("A1").SpecialCells(xlLastCell))

For Each Row In wsRng.Rows
    If foundRng Is Nothing Then
        Set tempRng = Nothing
        Set tempRng = wsRng.Find(What:=sstring, After:=ActiveCell, _
        LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _
        SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False)
        tempRng.Activate
        Set foundRng = tempRng.EntireRow
        foundAdd.Add tempRng.EntireRow.Address
    Else
        Set tempRng = Nothing
        Set tempRng = wsRng.Find(What:=sstring, After:=ActiveCell, _
        LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _
        SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False)
        tempRng.Activate

        If Not Intersect(foundRng, tempRng) Is Nothing Then Exit For
        Set foundRng = Union(foundRng, tempRng.EntireRow)
        foundAdd.Add tempRng.EntireRow.Address
    End If
Next

'I think this macro can be improved by looping directly with foundRng _
instead of foundAdd. So you wont need foundAdd at all.

For i = 1 To foundAdd.Count
Sheets("Sheet2").Rows(CountCopyToRow).Value = _
                    ws.Range(foundAdd(i)).Value
CountCopyToRow = CountCopyToRow + 1
Next

End Sub