PDA

View Full Version : Optimize a VBA loop



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

snb
03-17-2014, 06:26 AM
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
03-17-2014, 06:41 AM
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
03-17-2014, 07:35 AM
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