Previous Topic Next Topic

Search for specific text & copy Row+next Row

Closed
Naim - Jun 5, 2012 at 09:33 AM
venkat1926 Posts 1863 Registration date Sunday June 14, 2009 Status Contributor Last seen August 7, 2021 - Jun 6, 2012 at 03:18 AM
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
Related:

1 response

Answer 1 / 1
venkat1926 Posts 1863 Registration date Sunday June 14, 2009 Status Contributor Last seen August 7, 2021 811
Jun 6, 2012 at 03:18 AM
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
0