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

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

Not your problem but you do want to [avoid using activate and select](https://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba). — cybernetic.nomad, Apr 04 '19 at 22:01

Tim Williams · Answer 1 · 2019-04-11T08:44:23.570

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

edited Apr 11 '19 at 08:44

answered Apr 04 '19 at 22:01

Tim Williams

154,628
8
97
125

I'm getting a Run-time error '13' Type mismatch when I run this code. @TimWilliams – Josh B Apr 04 '19 at 22:23
On which line? Do any of the cells in ColA have errors? – Tim Williams Apr 04 '19 at 22:42
1

I just looked at your screenshot - it doesn't seem to match your code. – Tim Williams Apr 04 '19 at 22:57
I'm not sure what line it's getting that error from. It doesn't say. And yeah my screenshot shows the expected output in Column B because it was easier than showing it in another sheet. – Josh B Apr 04 '19 at 23:20
I mean you show all data in one cell not on separate rows – Tim Williams Apr 05 '19 at 00:57
There's about 9000 rows under it that will follow a similar pattern of jumbled mess. The right side is what I would like all of the cells to look like all the way down. @TimWilliams – Josh B Apr 08 '19 at 16:33
In other words, there are several "sub-rows" of data within each cell that I need to clean up. Does that make more sense? @TimWilliams – Josh B Apr 08 '19 at 16:35

score 0 · Answer 2 · answered Apr 10 '19 at 21:22

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

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

2 Answers2