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

Question

您好我有以下VBA代码，我尝试将其用于将符合特定条件的行复制并粘贴到新工作表中。

代码运行到复制工作表中的第一个匹配但没有粘贴在第二个工作表上并显示错误

  

运行时错误＆＃39; 14004＆＃39;：应用程序定义或对象定义的错误

有人可以帮忙吗？

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

这可能足以摆脱所有那些通常会导致问题并且很少需要的选择（只需要添加工作表引用）。但是，AutoFilter或Find将是更快的方法。

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