Search for partial text within a row of data in a cell and extract whole string and row underneath - excel

Question

I'm trying to clean up some data in a column in Excel but it has too many rows to do it manually and the data I want is mixed up with irrelevant values.
Essentially, I need a VBA macro to search each cell in column A of Sheet1 for any row that contains the partial string "SAAM" and then copy both the full string attached to it and the next row of data directly underneath each instance to a separate sheet (Sheet2).
I expect the output to show what is shown in the attached image. I put the expected result in column B for clarity but I really want it in Sheet2 Column A.
My script currently ends up moving the full contents of the cell to Sheet2.
Sub Test()
For Each Cell In Sheets(1).Range("A:A")
If InStr(Cell.Value, "SAAM") > 0 Then
matchRow = Cell.Row
Rows(matchRow & ":" & matchRow + 1).Select
Selection.Copy
lastRow = ActiveSheet.UsedRange.Rows.Count
If lastRow > 1 Then lastRow = lastRow + 1
ActiveSheet.Range("B" & lastRow).Select
ActiveSheet.Paste
Sheets("Sheet1").Select
End If
Next
End Sub

Answer 1

Something like this (note this was based on looking at your code, not at the screenshot, which tells a different story...)
Sub Test()
For Each Cell In Sheets(1).UsedRange.Columns(1).Cells
If Not IsError(Cell.Value) Then
If InStr(Cell.Value, "SAAM") > 0 Then
'copy to first empty row
Cell.Resize(2,1).Entirerow.copy _
Sheets(2).Cells(rows.count, 1).end(xlup).offset(1,0)
End If 'has substring
End If 'not error
Next
End Sub
Edit: seem like you want something more like this, based on your screenshot (untested)
Sub Test()
Dim arr, i as long, sep
For Each Cell In Sheets(1).UsedRange.Columns(1).Cells
If Not IsError(Cell.Value) Then
If InStr(Cell.Value, "SAAM") > 0 Then
arr = Split(Cell.Value, vbLf) 'split cell content on newline
sep = ""
For i = lbound(arr) to ubound(arr)-1
if arr(i) like "*SAAM*" then
with cell.offset(0, 1)
.value = .value & sep & arr(i) & vbLf & arr(i+1)
sep = vbLf & vbLf
end with
end if
Next i
End If 'has substring
End If 'not error
Next
End Sub

Answer 2

Based on your code I’ll modify it this way:
Sub Test()
For Each Cell In Sheets(1).Range("A:A")
If InStr(Cell.Value, "SAAM") > 0 Then
matchRow = Cell.Row
Sheets(1).Cells(matchRow,1).Copy
lastRow = Sheets(2).Cells(Rows.Count,1).End(xlUp).Row + 1
Sheets(2).Range("B" & lastRow).Select
Sheets(2).PasteSpecial Paste:=xlPasteValues
Sheets(1).Select
End If
Next
End Sub