I tried many codes and combine them to achieve But there is a problem with this code and i need help.
I want my code to input a specific word (in specific column) and search all worksheet to find match then, copy multiple rows that have a same value and paste in some new sheet.
Thank You
Here is code:
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
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
I guess you may be after this revision of your code:
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
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.