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

Question

嗨，我有以下VBA代码，我正在尝试将这些代码用于excel，以便将满足特定条件的行复制并粘贴到新表中。

该代码运行到复制工作表中的第一个匹配项的位置，但是粘贴到第二个工作表时失败，并显示以下错误

运行时错误“ 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

消除通常会引起问题且很少需要的所有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

验收测试程序脚本

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