CODEWITHSUNDEEP
excelvba
Josh B
Josh B

Reputation: 3

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

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.

Attached image

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

Upvotes: 0

Views: 1124

Answers (2)

Tim Williams
Tim Williams

Reputation: 166306

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

Upvotes: 1

user8608712
user8608712

Reputation:

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

Upvotes: 0

Related Questions