You need to remove all that selecting, and reduce the moving data around
Sub InventionCashFlows() 'Creates cash flow for each unique invention Dim target As Worksheet Dim numInventions As Long Dim lastrow As Long Dim i As Long Application.ScreenUpdating = False Set target = Worksheets("Inventions") target.Rows(19).Resize(target.UsedRange.Rows.Count).Clear With Worksheets("Data") numInventions = Application.CountA(.Range("A2", .Range("A2").End(xlDown))) - 1 End With With target For i = 1 To numInventions .Rows("2:18").Copy .Cells((i - 1) * 17 + 2, "A") .Cells((i - 1) * 17 + 2, "A").Formula = "=Data!A" & i + 1 Next i End With Application.ScreenUpdating = True End Sub