Copy and paste nonblank cells from sheet1 to sheet2

Question

I'm trying to copy and paste nonblank cells from sheet1 to sheet2.

I'm getting application/object error.

Public Sub CopyRows()
    Sheets("Sheet1").Select
    FinalRow = Cells(Rows.Count, 1).End(xlDown).Row
    For x = 4 To FinalRow
        ThisValue = Cells(x, 1).Value
        NextRow = Cells(Rows.Count, 1).End(xlDown).Row
        If Not IsEmpty(ThisValue) Then
            Cells(x, 1).Resize(1, 6).Copy
            Sheets(2).Select
            Cells(NextRow, 1).Select
            ActiveSheet.Paste
            Sheets(1).Select
        End If
    Next x
End Sub

In general, you want to [avoid using Select](https://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba) in your code. It's also better to specify which sheet a given range is in (ex.: `Sheets(1).Cells(x, 1).Value` instead of `Cells(x, 1).Value`) — cybernetic.nomad, Apr 21 '22 at 16:24

score 1 · Answer 1 · answered Apr 21 '22 at 16:36

Copy Rows

Option Explicit

Sub CopyRows()
    
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Source
    Dim sws As Worksheet: Set sws = wb.Worksheets("Sheet1")
    Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, "A").End(xlUp).Row
    If slRow < 4 Then Exit Sub ' no data
    
    ' Destination
    Dim dws As Worksheet: Set dws = wb.Worksheets("Sheet2")
    Dim dCell As Range: Set dCell = dws.Cells(dws.Rows.Count, "A").End(xlUp)
    
    Application.ScreenUpdating = False
    
    Dim sCell As Range
    Dim sr As Long
    
    ' Loop and copy.
    For sr = 4 To slRow
        Set sCell = sws.Cells(sr, "A")
        If Not IsEmpty(sCell) Then
            Set dCell = dCell.Offset(1)
            sCell.Resize(, 6).Copy dCell
        End If
    Next sr
    
    Application.ScreenUpdating = True
    
    ' Inform.
    MsgBox "Rows copied.", vbInformation
    
End Sub

score 1 · Answer 2 · answered Apr 21 '22 at 16:54

There are multiple problems in your original code. As cybernetic.nomad already pointed out, avoid using Select whenever possible. You also set your NextRow variable to always be the last row in the worksheet instead of the next available row in your destination sheet. Additionally, because of your use of .Select, you have ambiguous Cells calls.

Here is an alternate method using AutoFilter because, for this task, you can take advantage of filtering to only get populated cells without having to perform a loop:

Sub CopyRows()
    
    Dim wb As Workbook:     Set wb = ActiveWorkbook
    Dim wsSrc As Worksheet: Set wsSrc = wb.Worksheets("Sheet1")
    Dim wsDst As Worksheet: Set wsDst = wb.Worksheets("Sheet2")
    Dim rData As Range:     Set rData = wsSrc.Range("A3", wsSrc.Cells(wsSrc.Rows.Count, "A").End(xlUp))
    If rData.Rows.Count < 2 Then Exit Sub  'No data
    
    With rData
        .AutoFilter 1, "<>"
        .Offset(1).Resize(, 6).Copy wsDst.Cells(wsDst.Rows.Count, "A").End(xlUp).Offset(1)
        .AutoFilter
    End With
    
End Sub

Copy and paste nonblank cells from sheet1 to sheet2

2 Answers2

Copy Rows