-
1 Attachment(s)
Optimize a VBA loop
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:
Code:
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
-
Code:
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
-
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.
Code:
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.
Code:
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
-
You need to remove all that selecting, and reduce the moving data around
Code:
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