VBA复制并附加

时间:2013-12-17 16:57:29

标签: excel vba excel-vba

我尝试包含一个副本并附加到新工作表之前删除整行并添加额外的行到底部。这就是我到目前为止所拥有的

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

2 个答案:

答案 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