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

[snb]

Sub M_snb()
   sn = Sheets("data").Columns(1).SpecialCells(2)
   
   For J = 2 To UBound(sn)
      Sheets("inventions").cells(17 * (J - 2) + 2, 1) = sn(J, 1)
   Next
End Sub

[ashleyuk1984]

I ran it once, and it took quite a while to complete (as you know), and hurt my eyes from all the flickering lol.
So I put Application.Screenupdating into the macro and it seemed to run a lot faster, and didn't hurt my eyes either.

Put this at the top of your macro.

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

Application.ScreenUpdating = False '<------------------------------------ THIS LINE

With Sheets("Inventions")
    .Rows(18 & ":" & .Rows.Count).Clear
End With

And this at the bottom of your macro.

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

Application.ScreenUpdating = True '<------------------------------------ THIS LINE

End Sub

Original Code = 42 Seconds to complete
Edited code with screenupdating = 8 Seconds to complete

[Bob Phillips]

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