CODEWITHSUNDEEP
vbaexcel
SDROB
SDROB

Reputation: 125

Excel VBA code to copy and paste rows to new sheet failing

Hi I have the following VBA code that I am trying to use for excel to copy and paste rows that meet a certain criteria to a new sheet.

The code runs to the point of copying the first match in the sheet but fails pasting on the second sheet with the error

Run-time error '14004': Application-defined or object-defined error

Can anyone help here? 

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

Image as is Image required

Upvotes: 1

Views: 819

Answers (2)

SJR
SJR

Reputation: 23081

It might be enough to get rid of all those Selects which usually cause problems and are rarely needed (just need to add sheet references). However, AutoFilter or Find would be quicker methods.

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

Upvotes: 2

Bharath Kumar T
Bharath Kumar T

Reputation: 21

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

Acceptance Test Procedure Script

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

Upvotes: 0

Related Questions