Option Explicit Sub TransferData() Dim TargetRow As Long Dim LastRow As Long Dim Rw As Long Dim rSource As Range LastRow = Sheet1.Cells(Rows.Count, "A").End(xlUp).Row TargetRow = Sheet2.Cells(Rows.Count, "A").End(xlUp).Offset(1).Row For Rw = 2 To LastRow Set rSource = Sheet1.Range(Sheet1.Cells(Rw, 1), Sheet1.Cells(Rw, 5)) If rSource.Cells(1) <> "" Then rSource.Copy Sheet2.Cells(TargetRow, "A").PasteSpecial Paste:=xlPasteValues Sheet2.Cells(TargetRow, "A").PasteSpecial Paste:=xlPasteFormats TargetRow = TargetRow + 1 End If Next Rw End Sub