Insert blank row after paste in VBA

[Davebro]

I have the following VBA to copy cells into a sheet 2, is there any way that when I paste it inserts a blank row after the paste?


Sub copycolumns()
Dim lastrow As Long, erow As Long

lastrow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastrow
If Sheet1.Cells(i, 10) = "Home" And Sheet1.Cells(i, 1) > 2 Then
Sheet1.Cells(i, 1).Copy
erow = Sheet2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
Sheet1.Paste Destination:=Worksheets("Sheet2").Cells(erow, 1)

Sheet1.Cells(i, 2).Copy
Sheets("Sheet2").Cells(erow, 2).PasteSpecial xlPasteValues

Sheet1.Cells(i, 3).Copy
Sheet1.Paste Destination:=Worksheets("Sheet2").Cells(erow, 3)

Sheet1.Cells(i, 10).Copy
Sheet1.Paste Destination:=Worksheets("Sheet2").Cells(erow, 4)

End If
Next i

Application.CutCopyMode = False
Sheet2.Columns.AutoFit
Range("A1").Select

End Sub

 

[Davebro]

Sub InsertRows1() With Application .ScreenUpdating = False .DisplayAlerts = False End With With Sheets("Sheet2").Range("A1", Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp)) .Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(1), _ Replace:=True, PageBreaks:=False, SummaryBelowData:=True .Offset(2, -1).SpecialCells(xlCellTypeConstants).Offset(, 1).ClearContents .Offset(, -1).EntireColumn.Delete .EntireColumn.RemoveSubtotal End With With Application .DisplayAlerts = True .ScreenUpdating = True End With End Sub

Still getting the spacing every other row, I will try again tomorrow with some other data and see how it comes out, many thanks for your time (and patience), much appreciated.