jblack6572
03-17-2014, 05:53 AM
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
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