Excel VBA代码复制和粘贴行到新工作表失败

嗨，我有以下的VBA代码，我正在尝试用于复制和粘贴满足一定条件的行到一个新的工作表。

代码运行到复制工作表中的第一个匹配的位置，但是在错误的第二个工作表上粘贴失败

运行时错误“14004”：应用程序定义或对象定义的错误

任何人都可以帮忙吗？

Sub mileStone() Dim r As Long, pasteRowIndex As Long Dim lastRow As Long 'lastRow = sht.Range("A1").CurrentRegion.Rows.Count lastRow = 24 ' need to include function to retrieve the last used row number pasteRowIndex = 1 For r = 11 To lastRow 'Loop through sheet1 and search for your criteria If Cells(r, Columns("E").Column).Value = "defect resolution" Then 'Found 'Copy the current row Rows(r).Select Selection.Copy 'Switch to the sheet where you want to paste it & paste Sheets("Sheet2").Select Rows(pasteRowIndex).Select ActiveSheet.Paste 'Next time you find a match, it will be pasted in a new row pasteRowIndex = pasteRowIndex + 1 'Switch back to your table & continue to search for your criteria Sheets("Sheet1").Select End If Next r End Sub 

Answer 1

摆脱所有那些通常会导致问题而且很less需要的select（只需要添加工作表引用）就足够了。 但是，自动筛选或查找将是更快的方法。

 Sub mileStone() Dim r As Long, pasteRowIndex As Long, v() As Long, i As Long Dim lastRow As Long 'lastRow = sht.Range("A1").CurrentRegion.Rows.Count lastRow = 13 '24 ' need to include function to retrieve the last used row number pasteRowIndex = 1 With Sheets("Sheet1") For r = 11 To lastRow If .Cells(r, "E").Value Like "defect resolution*" Then If UBound(Split(.Cells(r, "E"), ",")) > 0 Then i = i + 1 ReDim v(1 To i) v(i) = pasteRowIndex End If Sheets("Sheet1").Rows(r).Copy Sheets("Sheet2").Rows(pasteRowIndex) pasteRowIndex = pasteRowIndex + 1 End If Next r End With With Sheets("Sheet2") If IsArray(v) Then .Columns(6).Insert shift:=xlToRight For i = LBound(v) To UBound(v) .Cells(v(i), "F") = Split(.Cells(v(i), "E"), ",")(1) .Cells(v(i), "E") = Split(.Cells(v(i), "E"), ",")(0) Next i End If End With End Sub 

Answer 2

 Sub Copy_Filtered_Sections() Dim Section As Long, NextRow As Long For Section = 1 To 32 NextRow = Sheets("Results").Range("A" & Rows.Count).End(xlUp).Row + 1 'Next empty row Sheets("Function Test Procedure").Select Range("FTPSec" & Section).Columns("A:H").SpecialCells(xlCellTypeVisible).Copy _ Destination:=Sheets("Results").Range("A" & NextRow) ' Range("FTPSec" & Section).Columns("G:H").SpecialCells(xlCellTypeVisible).Copy _ ' Destination:=Sheets("Results").Range("N" & NextRow) Next Section End Sub 

验收testing程序脚本

 Sub Copy_ATP_Tables() Dim SectionATP As Long, NextRow As Long For SectionATP = 1 To 32 NextRow = Sheets("Results").Range("A" & Rows.Count).End(xlUp).Row + 1 'Next empty row Sheets("Acceptance Test Procedure").Select Range("ATPSec" & SectionATP).Columns("A:H").SpecialCells(xlCellTypeVisible).Copy _ Destination:=Sheets("Results").Range("A" & NextRow) ' Range("FTPSec" & Section).Columns("G:H").SpecialCells(xlCellTypeVisible).Copy _ ' Destination:=Sheets("Results").Range("N" & NextRow) Next SectionATP End Sub