剪切包含关键字的特定单元格的整行，并将其粘贴到新工作表中，同时向上移动其余单元格以填充空格

Sub MoveRowsWithKeyword()
    Dim wsSource As Worksheet
    Dim wsTarget As Worksheet
    Dim rng As Range
    Dim cell As Range
    Dim lastRow As Long
    
    ' 设置源工作表和目标工作表
    Set wsSource = ThisWorkbook.Sheets("Sheet1")
    Set wsTarget = ThisWorkbook.Sheets("Sheet2")
    
    ' 查找关键字所在的单元格
    Set rng = wsSource.Range("A1:A" & wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row)
    
    For Each cell In rng
        If InStr(cell.Value, "关键字") > 0 Then
            ' 剪切整行并粘贴到目标工作表
            cell.EntireRow.Cut Destination:=wsTarget.Cells(wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row + 1, "A")
            ' 删除源工作表中的空行
            cell.EntireRow.Delete Shift:=xlShiftUp
        End If
    Next cell
End Sub