[英]Search Specific Value and Copy Row to paste in new Sheet from Entire Workbook
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
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.