Search for specific text & copy Row+next RowClosed

Question

Search for text and copy row + next row to different sheet
I have sheet1 and sheet2. All my raw data is in Sheet2 and Sheet1 will be summary report. I want my script to search each cell in Sheet2-ColumnA and search for "test00". If find, copy entire row which contains "test00" and also copy next row and paste it in sheet2. There are multiple entries on "test00" in Sheet2 so I need this to find all entries and copy in Sheet2. Here is an example. 
Sheet2:

Column A
test00
Hello-A6
test01
Hello-A6
test02
Hello-A10
test00
Hello-A12

Sheet1 should look like this after running script.

Column A
test00
Hello-A6
test00
Hello-A12

This is what I have so far but this scrip does not loop. It only copies first found entry. 


Sub testme()
Dim FoundCell As Range

With Worksheets("Sheet1")
Set FoundCell = .Cells.Find(What:="*GradeA*", _
After:=.Cells(.Cells.Count), LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False)
End With

If FoundCell Is Nothing Then
MsgBox "Not found"
Else
FoundCell.Resize(2, 1).EntireRow.Copy
        Sheet2.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

End If
End Sub

With this script output looks like this 
Column A
test00
Hello-A6

venkat1926 · Answer

there is a gradeA in macro. where doe this come in 
 when you enter preferably do not enter spaces before or after 
for example it looks while copying your data the cell values for e.g 
test00<space>
such leading  and following spaces should be avoided in entering cells.

see the modified macro (this will loop)

Sub testme()
Dim FoundCell As Range
Dim add As String
With Worksheets("Sheet1")
Set FoundCell = .Cells.Find(What:="*test00*", lookat:=xlWhole)



If FoundCell Is Nothing Then
MsgBox "Not found"
Else
add = FoundCell.Address
FoundCell.Resize(2, 1).EntireRow.Copy
        Sheet2.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

End If
Do
Set FoundCell = .Cells.FindNext(FoundCell)
If FoundCell Is Nothing Then Exit Do
If FoundCell.Address = add Then Exit Do
FoundCell.Resize(2, 1).EntireRow.Copy
        Sheet2.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Loop
End With
End Sub

Search for specific text & copy Row+next Row

1 response

Similar discussions

Subscribe To Our Newsletter!