VBA複製並附加

我試圖包括一個副本並追加到新的工作表之前刪除整行並添加額外的行到底部。這是我到目前爲止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

來源

2013-12-17 grahamie

不太明白你想用'範圍（「C5499：F5499」）做什麼。選擇 Selection.AutoFill目的地：=範圍（「C5499：F5500」），類型：= xlFillDefault 範圍（「C5499：F5500」）。選擇 Selection.End（xlUp）.Select' –

將公式複製到下一行，因此表中總是有5000行。每次刪除一行時，都會在底部添加一行。這工作完美，我只需要添加複製和粘貼/ ammend部分 – grahamie

複製什麼到最後一行？ –

所以像這樣？

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

來源

2013-12-17 18:43:46

感謝您的提示。我設法將它拼湊在一起，並提出以下建議。

有關添加選擇性粘貼（值）的任何提示？

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

來源

2013-12-17 21:55:26 grahamie

VBA複製並附加

回答

相關問題