Find next empty row issue

[Bungraman]

I have this code that copies 4 cells of data and pastes them in the next available "blank" row. So for example: Row 3/ (col A) = 111, (B) =222, (C) 333 and (D) 444. Sometimes Colum A & B does not contain any values but C & D do, now when I run this code (below) it copies ok to the next empty row, but when Columns A & B are empty, it copies across ok, but in the next loop if A & B are present, it overwrites (pastes onto) the row that has no values/data in column A & B. It is as if the code sees the empty "A" cell and determines the entire row is empty when sometimes it is not.

Basically is this code looking at each row entirely to see if it is empty?

Sub Copy_And_Arrange_Seperate_Sheet()

Dim i As Long

Dim copySheet As Worksheet
Dim pasteSheet As Worksheet

    
    Set copySheet = Worksheets("Sheet1")
    Set pasteSheet = Worksheets("Sheet2")
        copySheet.Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(0, 3)).Copy

    For i = 1 To 13
    pasteSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
    Application.CutCopyMode = False
    
    copySheet.Select
    ActiveCell.Offset(0, 4).Select
        copySheet.Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(0, 3)).Copy
    
    Next i
    

End Sub

Can anyone suggest a fix?

 

[mart37]

pasteSheet.Cells(ActiveSheet.UsedRange.Rows.Count, 1).Offset(1, 0).PasteSpecial xlPasteValues

 

[Bungraman]

What it needs to do is copy these cells to "Sheet2" . . . . .

And give this . . . . .

But what it is doing is recognizing the cells that have no values in column A & B as a empty row, and pasting newer values over the top. Such as . . . . .

Just thought pictures might explain it better.

 

[Bungraman]

pasteSheet.Cells(ActiveSheet.UsedRange.Rows.Count, 1).Offset(1, 0).PasteSpecial xlPasteValues

Thanks mart37, it didn't work. Returned only one 4 cell group down on Row 63??

 

[Snakehips]

Not tested but maybe try...

Sub Copy_And_Arrange_Seperate_Sheet()

Dim i As Long

Dim copySheet As Worksheet
Dim pasteSheet As Worksheet

    
    Set copySheet = Worksheets("Sheet1")
    Set pasteSheet = Worksheets("Sheet2")
    PstRow = 0
    For c = 1 To 4
    LstRow = pasteSheet.Cells(Rows.Count, c).End(xlUp).Row
    If LstRow > PstRow Then PstRow = LstRow
    Next c
        copySheet.Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(0, 3)).Copy

    For i = 1 To 13
    
    pasteSheet.Cells(i + PstRow, 1).PasteSpecial xlPasteValues
    Application.CutCopyMode = False
    
    copySheet.Select
    ActiveCell.Offset(0, 4).Select
        copySheet.Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(0, 3)).Copy
    
    Next i
    

End Sub

 

[Bungraman]

Thanks Tony, "not tested" but it worked a treat . Thanks for your help.