Macro Speed Improvement

B

Bkisley

Board Regular
Joined
Jan 5, 2017
Messages
100
Below is a code that I have for a complicated model I created.

Each time I click the button to run the macro it takes roughly 30 seconds. I know it may not seem like that long of a time to wait, but when you have to click this button a lot of times it is not efficient. Can you guys look this over and recommend any changes that will increase the speed to run it. It should go without saying, but just in case, I can't change the actions of this macro.

Sub onedown()
Dim rw As Integer
Dim lastCol As Integer

ActiveWorkbook.Save

rw = Selection.Row + 1
lastCol = Cells(1, Columns.Count).End(xlToLeft).Column

Range("A1").SpecialCells (xlCellTypeBlanks)
Rows(rw).Insert CopyOrigin:=xlFormatFromLeftOrAbove

With Cells(rw, 1).Resize(, lastCol)
.Interior.ThemeColor = xlThemeColorDark1
.Borders.LineStyle = xlNone
End With

Range("E" & rw).FormulaR1C1 = Range("E" & rw - 1).FormulaR1C1
Range("H" & rw).FormulaR1C1 = Range("H" & rw - 1).FormulaR1C1
Range("L" & rw).FormulaR1C1 = Range("L" & rw - 1).FormulaR1C1
Range("P" & rw).FormulaR1C1 = Range("P" & rw - 1).FormulaR1C1
Range("Q" & rw).FormulaR1C1 = Range("Q" & rw - 1).FormulaR1C1
Range("R" & rw).FormulaR1C1 = Range("R" & rw - 1).FormulaR1C1
Range("X" & rw).FormulaR1C1 = Range("X" & rw - 1).FormulaR1C1
Range("Y" & rw).FormulaR1C1 = Range("Y" & rw - 1).FormulaR1C1
Range("Z" & rw).FormulaR1C1 = Range("Z" & rw - 1).FormulaR1C1
Range("AA" & rw).FormulaR1C1 = Range("AA" & rw - 1).FormulaR1C1
Range("AB" & rw).FormulaR1C1 = Range("AB" & rw - 1).FormulaR1C1
Range("AC" & rw).FormulaR1C1 = Range("AC" & rw - 1).FormulaR1C1
Range("AD" & rw).FormulaR1C1 = Range("AD" & rw - 1).FormulaR1C1
Range("AE" & rw).FormulaR1C1 = Range("AE" & rw - 1).FormulaR1C1
Range("AF" & rw).FormulaR1C1 = Range("AF" & rw - 1).FormulaR1C1
Range("AG" & rw).FormulaR1C1 = Range("AG" & rw - 1).FormulaR1C1
Range("AH" & rw).FormulaR1C1 = Range("AH" & rw - 1).FormulaR1C1
Range("AI" & rw).FormulaR1C1 = Range("AI" & rw - 1).FormulaR1C1
Range("AJ" & rw).FormulaR1C1 = Range("AJ" & rw - 1).FormulaR1C1
Range("AK" & rw).FormulaR1C1 = Range("AK" & rw - 1).FormulaR1C1
Range("AL" & rw).FormulaR1C1 = Range("AL" & rw - 1).FormulaR1C1
Range("AP" & rw).FormulaR1C1 = Range("AP" & rw - 1).FormulaR1C1
Range("AU" & rw).FormulaR1C1 = Range("AU" & rw + 1).FormulaR1C1
Range("AV" & rw).FormulaR1C1 = Range("AV" & rw + 1).FormulaR1C1
Range("AW" & rw).FormulaR1C1 = Range("AW" & rw + 1).FormulaR1C1
Range("AX" & rw).FormulaR1C1 = Range("AX" & rw + 1).FormulaR1C1
Range("AY" & rw).FormulaR1C1 = Range("AY" & rw + 1).FormulaR1C1
Range("AZ" & rw).FormulaR1C1 = Range("AZ" & rw + 1).FormulaR1C1
Range("BA" & rw).FormulaR1C1 = Range("BA" & rw + 1).FormulaR1C1
Range("BB" & rw).FormulaR1C1 = Range("BB" & rw + 1).FormulaR1C1
Range("BC" & rw).FormulaR1C1 = Range("BC" & rw + 1).FormulaR1C1
Range("BD" & rw).FormulaR1C1 = Range("BD" & rw + 1).FormulaR1C1
Range("BE" & rw).FormulaR1C1 = Range("BE" & rw + 1).FormulaR1C1
Range("BF" & rw).FormulaR1C1 = Range("BF" & rw + 1).FormulaR1C1
Range("BG" & rw).FormulaR1C1 = Range("BG" & rw + 1).FormulaR1C1
Range("BH" & rw).FormulaR1C1 = Range("BH" & rw + 1).FormulaR1C1
Range("BI" & rw).FormulaR1C1 = Range("BI" & rw + 1).FormulaR1C1
Range("I" & rw).Select
End Sub
 
Last edited:

Excel Facts

Bring active cell back into view
Start at A1 and select to A9999 while writing a formula, you can't see A1 anymore. Press Ctrl+Backspace to bring active cell into view.
Sort by date Sort by votes
How about
Code: 
Sub onedown()
   Dim rw As Integer
   Dim lastCol As Integer
Application.Calculation = xlCalculationManual
   ActiveWorkbook.Save
   
   rw = Selection.Row + 1
   lastCol = Cells(1, Columns.Count).End(xlToLeft).Column
   
   Rows(rw).Insert CopyOrigin:=xlFormatFromLeftOrAbove
   
   With Cells(rw, 1).Resize(, lastCol)
      .Interior.ThemeColor = xlThemeColorDark1
      .Borders.LineStyle = xlNone
   End With
   
   Range("E" & rw).FormulaR1C1 = Range("E" & rw - 1).FormulaR1C1
   Range("H" & rw).FormulaR1C1 = Range("H" & rw - 1).FormulaR1C1
   Range("L" & rw).FormulaR1C1 = Range("L" & rw - 1).FormulaR1C1
   Range("P" & rw).Resize(, 3).FormulaR1C1 = Range("P" & rw - 1).Resize(, 3).FormulaR1C1
   Range("X" & rw).Resize(, 15).FormulaR1C1 = Range("X" & rw - 1).Resize(, 15).FormulaR1C1
   Range("AL" & rw).FormulaR1C1 = Range("AL" & rw - 1).FormulaR1C1
   Range("AP" & rw).FormulaR1C1 = Range("AP" & rw - 1).FormulaR1C1
   Range("AU" & rw).Resize(, 15).FormulaR1C1 = Range("AU" & rw + 1).Resize(, 15).FormulaR1C1
   Range("I" & rw).Select
Application.Calculation = xlCalculationAutomatic

End Sub
 
Upvote 0
Bkisley said:
Below is a code that I have for a complicated model I created.

Each time I click the button to run the macro it takes roughly 30 seconds. I know it may not seem like that long of a time to wait, but when you have to click this button a lot of times it is not efficient. Can you guys look this over and recommend any changes that will increase the speed to run it. It should go without saying, but just in case, I can't change the actions of this macro.

Sub onedown()
Dim rw As Integer
Dim lastCol As Integer

ActiveWorkbook.Save

rw = Selection.Row + 1
lastCol = Cells(1, Columns.Count).End(xlToLeft).Column

Range("A1").SpecialCells (xlCellTypeBlanks)
Rows(rw).Insert CopyOrigin:=xlFormatFromLeftOrAbove

With Cells(rw, 1).Resize(, lastCol)
.Interior.ThemeColor = xlThemeColorDark1
.Borders.LineStyle = xlNone
End With

Range("E" & rw).FormulaR1C1 = Range("E" & rw - 1).FormulaR1C1
Range("H" & rw).FormulaR1C1 = Range("H" & rw - 1).FormulaR1C1
Range("L" & rw).FormulaR1C1 = Range("L" & rw - 1).FormulaR1C1
Range("P" & rw).FormulaR1C1 = Range("P" & rw - 1).FormulaR1C1
Range("Q" & rw).FormulaR1C1 = Range("Q" & rw - 1).FormulaR1C1
Range("R" & rw).FormulaR1C1 = Range("R" & rw - 1).FormulaR1C1
Range("X" & rw).FormulaR1C1 = Range("X" & rw - 1).FormulaR1C1
Range("Y" & rw).FormulaR1C1 = Range("Y" & rw - 1).FormulaR1C1
Range("Z" & rw).FormulaR1C1 = Range("Z" & rw - 1).FormulaR1C1
Range("AA" & rw).FormulaR1C1 = Range("AA" & rw - 1).FormulaR1C1
Range("AB" & rw).FormulaR1C1 = Range("AB" & rw - 1).FormulaR1C1
Range("AC" & rw).FormulaR1C1 = Range("AC" & rw - 1).FormulaR1C1
Range("AD" & rw).FormulaR1C1 = Range("AD" & rw - 1).FormulaR1C1
Range("AE" & rw).FormulaR1C1 = Range("AE" & rw - 1).FormulaR1C1
Range("AF" & rw).FormulaR1C1 = Range("AF" & rw - 1).FormulaR1C1
Range("AG" & rw).FormulaR1C1 = Range("AG" & rw - 1).FormulaR1C1
Range("AH" & rw).FormulaR1C1 = Range("AH" & rw - 1).FormulaR1C1
Range("AI" & rw).FormulaR1C1 = Range("AI" & rw - 1).FormulaR1C1
Range("AJ" & rw).FormulaR1C1 = Range("AJ" & rw - 1).FormulaR1C1
Range("AK" & rw).FormulaR1C1 = Range("AK" & rw - 1).FormulaR1C1
Range("AL" & rw).FormulaR1C1 = Range("AL" & rw - 1).FormulaR1C1
Range("AP" & rw).FormulaR1C1 = Range("AP" & rw - 1).FormulaR1C1
Range("AU" & rw).FormulaR1C1 = Range("AU" & rw + 1).FormulaR1C1
Range("AV" & rw).FormulaR1C1 = Range("AV" & rw + 1).FormulaR1C1
Range("AW" & rw).FormulaR1C1 = Range("AW" & rw + 1).FormulaR1C1
Range("AX" & rw).FormulaR1C1 = Range("AX" & rw + 1).FormulaR1C1
Range("AY" & rw).FormulaR1C1 = Range("AY" & rw + 1).FormulaR1C1
Range("AZ" & rw).FormulaR1C1 = Range("AZ" & rw + 1).FormulaR1C1
Range("BA" & rw).FormulaR1C1 = Range("BA" & rw + 1).FormulaR1C1
Range("BB" & rw).FormulaR1C1 = Range("BB" & rw + 1).FormulaR1C1
Range("BC" & rw).FormulaR1C1 = Range("BC" & rw + 1).FormulaR1C1
Range("BD" & rw).FormulaR1C1 = Range("BD" & rw + 1).FormulaR1C1
Range("BE" & rw).FormulaR1C1 = Range("BE" & rw + 1).FormulaR1C1
Range("BF" & rw).FormulaR1C1 = Range("BF" & rw + 1).FormulaR1C1
Range("BG" & rw).FormulaR1C1 = Range("BG" & rw + 1).FormulaR1C1
Range("BH" & rw).FormulaR1C1 = Range("BH" & rw + 1).FormulaR1C1
Range("BI" & rw).FormulaR1C1 = Range("BI" & rw + 1).FormulaR1C1

Range("I" & rw).Select
End Sub
Click to expand...
You can replace everything I highlighted in red above with this code snippet...
Code: 
With Intersect(Range("E:E,H:H,L:L,P:R,X:AL,P:P,U:BI").EntireColumn, Rows(rw))
  .FormulaR1C1 = .Offset(1).FormulaR1C1
End With
I am not sure if that change in and of itself will make a difference in speed execution or not. If it doesn't, you can try turning off automatic calculation until all the formulas are placed and then turn it back on afterwards.
Code: 
Application.Calculation = xlCalculationManual
With Intersect(Range("E:E,H:H,L:L,P:R,X:AL,P:P,U:BI").EntireColumn, Rows(rw))
  .FormulaR1C1 = .Offset(1).FormulaR1C1
End With
Application.Calculation = xlCalculationAutomatic
 
Last edited:
Upvote 0
This did not work Rick - assuming you missed a couple "A"'s above see fix below

Then it didn't work because the equation in column E is now in a lot of different columns not just column E like it should be. It is currently in columns P:R, X:AL, AP, AU:BI
The cells in those columns should pull directly from the cell above

With Intersect(Range("E:E,H:H,L:L,P:R,X:AL,AP:AP,AU:BI").EntireColumn, Rows(rw))
.FormulaR1C1 = .Offset(1).FormulaR1C1
End With
 
Upvote 0
@Fluff.... Initial tests on this....FANTASTIC!!!

Thank you so much! I'll get back to you if I spot something
 
Last edited:
Upvote 0
Not quite sure what your sub is doing. Try this one. It's faster. Test it on a copy of your workbook.
Code: 
Option Explicit

Sub onedownFaster()
   Dim rw As Long
   Dim lastCol As Long
   Dim ccs As Variant
   Dim fromRow As Variant, i As Long, j As Long
   '  Columns to copy
   '           E, H, L,   P,  Q,  R,  X,  Y,  Z, AA, AB, AC, AD, AE, _
               AF, AG, AH, AI, AJ, AK, AL, AP, AU, AV, AW, AX, _
               AY, AZ, BA, BB, BC, BD, BE, BF, BG, BH, BI
   '  Column numbers to copy
   ccs = Array(5, 8, 12, 16, 17, 18, 24, 25, 26, 27, 28, 29, 30, 31, _
               32, 33, 33, 34, 35, 36, 37, 42, 47, 48, 49, 50, _
               51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61)
   'ActiveWorkbook.Save
   
   rw = Selection.Row + 1
   lastCol = Cells(1, Columns.Count).End(xlToLeft).Column
   
   'Range("A1").SpecialCells (xlCellTypeBlanks) ?does nothing
   Rows(rw).Insert 'CopyOrigin:=xlFormatFromLeftOrAbove
   
   With Cells(rw, 1).Resize(, lastCol)
      .Interior.ThemeColor = xlThemeColorDark1
      .Borders.LineStyle = xlNone
   End With
   
   'get columns into the varian. note: creates a 2-dimensional array
   fromRow = Cells(rw - 1, 1).Resize(, lastCol).FormulaR1C1
   
   'erase columns that should not be copied
   j = 1
   For i = 0 To UBound(ccs)
      While j < ccs(i): fromRow(1, j) = "": j = j + 1: Wend
      j = j + 1
   Next i
   
   'put result in worksheet
   Cells(rw, 1).Resize(, lastCol).FormulaR1C1 = fromRow
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

C
  • Question
Data Validation IF Statement (Too Many Characters)
Replies
1
Views
221
SanjayGMusafir
SanjayGMusafir
R
  • Solved
VBA User selecting file now the code errors Type Mismatch
2 3 4
Replies
30
Views
2K
Alex Blakenburg
A
T
  • Question
VBA Macro running, but not saving to Sharepoint
Replies
3
Views
600
Fluff
Fluff
P
  • Solved
Find Max of Year
2
Replies
12
Views
259
bobsan42
bobsan42
J
  • Solved
help finding my error
Replies
1
Views
181
Proulxs
P

Forum statistics

Threads
1,216,124
Messages
6,128,991
Members
449,480
Latest member
yesitisasport

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top