Excel - If cell is not blank, copy specific row cells to Sheet 2

Question

Basically, if in Sheet1 the cell in Column I is Not Blank, copy cells A, B, I and L to Sheet 2 on the next available blank row. Loop until end of rows on Sheet1.

I keep getting an error 9 or 450 code at the .Copy line.

I have connected the Module to a button on Sheet2. Could this be the reason?

Or should I use something different from the CopyPaste function?

This is the code I've been trying to get to work.

Option Explicit

Sub copyPositiveNotesData()

    Dim erow As Long, lastrow As Long, i As Long

    lastrow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
    For i = 2 To lastrow
        If Sheet1.Cells(i, "I") <> "" Then
            Worksheets("Sheet1").Activate

            ' *** next line gives Err#450 "Wrong # of arguments or invalid property assignments" ****
            Worksheets("Sheet1").Range(Cells(i, "A"), Cells(i, "B"), _
                Cells(i, "I"), Cells(i, "L")).Copy

            Worksheets("Sheet2").Activate
            erow = WorkSheet2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
            ActiveSheet.Paste Destination:=Worksheets("Sheet2"). _
                Range(Cells(i, "A"), Cells(i, "B"), Cells(i, "C"), Cells(i, "D"))
            Worksheets("sheet1").Activate
        End If
    Next i
    Application.CutCopyMode = False

End Sub

Answer 1

You need to use Application.Union to merge 4 cells in a row, something like the code below:

Full Modified Code

Option Explicit

Sub copyPositiveNotesData()

Dim erow As Long, lastrow As Long, i As Long
Dim RngCopy As Range

With Worksheets("Sheet1")
    lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row

    For i = 2 To lastrow
        If Trim(.Cells(i, "I").Value) <> "" Then
            Set RngCopy = Application.Union(.Range("A" & i), .Range("B" & i), .Range("I" & i), .Range("L" & i))              
            RngCopy.Copy ' copy the Union range

            ' get next empty row in "Sheet2"
            erow = Worksheets("Sheet2").Cells(Worksheets("Sheet2").Rows.Count, 1).End(xlUp).Offset(1, 0).Row
            ' paste in the next empty row
            Worksheets("Sheet2").Range("A" & erow).PasteSpecial xlPasteAll
        End If
    Next i
End With

Application.CutCopyMode = False

End Sub

Answer 2

You may try this (Not tested)

Option Explicit

Sub copyPositiveNotesData()
    Intersect (Sheet1.Range("I2", Sheet1.Cells(.Rows.Count, "I").End(xlUp)).SpeciallCells(xlCellTypeConstants).EntireRow, Sheet1.Range("A:A", "B:B", "I:I", "L:L")).Copy Sheet2.Cells(Sheet2.Rows.Count, 1).End(xlUp).Offset(1, 0)
End Sub

Answer 3

Looks like the issue is that you are trying to copy multiple cells at once which isn't supported (try doing the same manually within the actual sheet). You need to copy either a single cell or a continuous range. You could either do 4 copy/pastes or could directly set the values in the destination sheet.

Try changing the copy/paste to the following (untested):

Sub copyPositiveNotesData()
    Dim erow As Long, lastrow As Long, i As Long, ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = Worksheets("Sheet1")
    Set ws2 = Worksheets("Sheet2")
    lastrow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
    For i = 2 To lastrow
        If Sheet1.Cells(i, "I") <> "" Then
           With ws2

               .Range("A" & i).Value = ws1.Range("A" & i).Value
               .Range("B" & i).Value = ws1.Range("B" & i).Value
               .Range("I" & i).Value = ws1.Range("I" & i).Value
               .Range("L" & i).Value = ws1.Range("L" & i).Value

           End With

       End If
    Next i

End Sub