我尝试包含一个副本并附加到新工作表之前删除整行并添加额外的行到底部。这就是我到目前为止所拥有的
Sub DeleteRows()
Dim c As Range
Dim cell As Range
Dim SrchRng As Range
Dim SrchStr As String
On Error GoTo Err_Execute
Set SrchRng = ActiveSheet.Range("B1:B5000")
SrchStr = InputBox("Please Enter Number")
For Each cell In SrchRng
If cell.Value = SrchStr Then cell.EntireRow.Delete
Next cell
Range("C5499:F5499").Select
Selection.AutoFill Destination:=Range("C5499:F5500"), Type:=xlFillDefault
Range("C5499:F5500").Select
Selection.End(xlUp).Select
Exit Sub
Err_Execute:
MsgBox "An error occurred."
End Sub
答案 0 :(得分:0)
这样的事情?
Dim cell As Range
Dim SrchRng As Range
Dim SrchStr As String
Dim pasteRow As Long
Set SrchRng = Sheets("Sheet1").Range("B1:B5000")
SrchStr = InputBox("Please Enter Number")
pasteRow = 1
For Each cell In SrchRng
If cell.Value = SrchStr Then
cell.EntireRow.Copy (ThisWorkbook.Sheets("Sheet8").Range("A" & pasteRow).EntireRow)
pasteRow = pasteRow + 1
cell.EntireRow.Delete
End If
Next cell
答案 1 :(得分:0)
感谢您的提示。我设法将它拼凑在一起并提出以下内容。
添加Paste Special(值)的任何提示?
Sub DeleteRows()
Dim c As Range
Dim cell As Range
Dim SrchRng As Range
Dim SrchStr As String
Dim lastRow As Long
On Error GoTo Err_Execute
Set SrchRng = Sheets("Incubate").Range("B8:B5000")
SrchStr = InputBox("Please Enter Lab Number")
lastRow = Sheets("Fridge").Range("B65536").End(xlUp).Row + 1
For Each cell In SrchRng
If cell.Value = "" Then
Exit For
End If
If cell.Value = SrchStr Then
cell.EntireRow.Copy Destination:=Sheets("Fridge").Range("a" & lastRow)
cell.EntireRow.Delete
End If
Next cell
Range("C5499:F5499").Select
Selection.AutoFill Destination:=Range("C5499:F5500"), Type:=xlFillDefault
Range("C5499:F5500").Select
Selection.End(xlUp).Select
Selection.End(xlUp).Select
Selection.End(xlUp).Select
Selection.End(xlToLeft).Select
Range("B8").Select
Exit Sub
Err_Execute:
MsgBox "An error occurred."
End Sub