Excel 搜索单元格中数据行中的部分文本，并提取整个字符串和下面的行

我试图在Excel中清理列中的一些数据，但它有太多的行，无法手动清理，并且我想要的数据与不相关的值混合在一起

基本上，我需要一个VBA宏来搜索Sheet1 a列中的每个单元格，查找包含部分字符串SAAM的任何行，然后将附加到它的完整字符串和每个实例正下方的下一行数据复制到单独的Sheet2表中

我希望输出显示所附图像中显示的内容。为了清楚起见，我把预期结果放在B栏，但我真的希望它放在A栏的第2张纸上。 我的脚本当前将单元格的全部内容移动到Sheet2

---

类似这样的注释是基于查看您的代码，而不是屏幕截图，它讲述了一个不同的故事

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

编辑：根据未经测试的屏幕截图，您似乎想要更像这样的东西

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

---

根据您的代码，我将对其进行如下修改：

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

---

这不是您的问题，但您确实希望。当我运行此代码时，遇到运行时错误“13”类型不匹配@蒂姆威廉姆森哪一行？ColA中的任何单元格都有错误吗？我刚刚看了你的屏幕截图-它似乎与你的代码不匹配。我不确定它是从哪一行得到错误的。它没有说。是的，我的屏幕截图在B列显示了预期的输出，因为这比在另一张表中显示要容易。我的意思是，你在一个单元格中显示所有数据，而不是在单独的行中

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