Question

我正在尝试清除Excel列中的某些数据，但是它有太多行要手动执行，而我想要的数据却与不相关的值混合在一起。

基本上，我需要一个VBA宏来在Sheet1的A列中的每个单元格中搜索包含部分字符串“ SAAM”的任何行，然后将附加的完整字符串以及每个数据的下一行直接复制到每个实例的下方到单独的工作表（Sheet2）。

我希望输出显示所附图像中显示的内容。为了清楚起见，我将预期结果放在B列中，但我确实希望在Sheet2列A中获得预期结果。我的脚本当前最终将单元格的全部内容移至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

类似的事情（请注意，这是基于查看您的代码，而不是基于截屏，截然不同的故事……）

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

Answer 2

根据您的代码，我将通过以下方式对其进行修改：

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

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

2 个答案: