Optimize a VBA loop

[jblack6572]

I've got a vba sub which I think can be optimized to work much faster. I have a list of names in Column A on a worksheet "Data":

Abe-2061-07
Abe-2159-08
Abe-2281-09
Abe-2430-10
ETC

On another worksheet "Inventions" I have a template which I want to copy for each name in the list. My vba code looks like:

Sub InventionCashFlows()
'Creates cash flow for each unique invention
Dim invention As Integer
Dim numberofinventions As Integer
Dim rowoffset As Integer
Dim namerowoffset As Integer
With Sheets("Inventions")
    .Rows(18 & ":" & .Rows.Count).Clear
End With
Sheets("Data").Select
invention = 1
numberofinventions = Application.WorksheetFunction.CountA(Range("a2", Range("a2").End(xlDown))) - 1
For invention = 1 To numberofinventions
rowoffset = invention * 17
namerowoffset = invention * 17 - 17
Sheets("Data").Select
    Range("a1").Offset(invention, 0).Select
    Selection.Copy
Sheets("Inventions").Select
    Range("A2").Offset(namerowoffset, 0).Select
    ActiveSheet.Paste
ActiveWorkbook.Worksheets("Inventions").Rows("2:17").Select
    Selection.Copy
    Range("A2").Offset(rowoffset, 0).Select
    ActiveSheet.Paste
    
Next invention
namerowoffset = invention * 17 - 17
Sheets("Data").Select
    Range("a1").Offset(invention, 0).Select
    Selection.Copy
Sheets("Inventions").Select
    Range("A2").Offset(namerowoffset, 0).Select
    ActiveSheet.Paste
    
Range("A1").Select
End Sub

Ideas on how to optimize?

Sample spreadsheet Attached