Поиск неполного текста в строке данных в ячейке и извлечение всей строки и строки внизу

Question

Я пытаюсь очистить некоторые данные в столбце в Excel, но в нем слишком много строк, чтобы сделать это вручную, и нужные данные смешиваются с нерелевантными значениями.

По сути, мне нужен макрос VBA для поиска каждой ячейки в столбце A Sheet1 для любой строки, которая содержит частичную строку «SAAM», а затем скопировать как полную строку, прикрепленную к нему, так и следующую строку данных непосредственно под каждым экземпляром. на отдельный лист (Sheet2).

Я ожидаю, что вывод покажет то, что показано на прикрепленном изображении. Я поместил ожидаемый результат в столбец B для ясности, но я действительно хочу его в Sheet2 Column 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