Поиск Specifi c Значение и Копировать строку, чтобы вставить в новый лист из всей книги

Question

Я перепробовал много кодов и объединил их для достижения, но есть проблема с этим кодом, и мне нужна помощь.

Я хочу, чтобы мой код вводил определенное c слово (в конкретном c столбце ) и выполните поиск по всему листу, чтобы найти соответствие, затем скопируйте несколько строк , которые имеют одинаковое значение, и вставьте в новый лист.

Спасибо

Вот код:

       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

Я думаю, вы можете быть после этой ревизии вашего кода:

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

Answer 2

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