Optimize macro

N

Nagini

New Member
Joined
Dec 11, 2016
Messages
34
Hello! I've written this macro, it takes 5 minutes to end the work and I think that maybe someone Knows how to optimize it to make ir faster!


Sub Macro2()


Application.ScreenUpdating = False
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False


Dim Indices, Calculos, Seleccion As Worksheet
Set Indices = Sheets("C.Indices")
Set Calculos = Sheets("CALCULOS")
Set Seleccion = Sheets("Sel.Mes")


Dim i As Integer
LastCol = Indices.Cells(1, Columns.Count).End(xlToLeft).Column
For i = 8 To LastCol

 Dim j As Integer
j = i - 6

Indices.Columns(i).Copy
Calculos.Select
Columns("D:D").PasteSpecial Paste:=xlPasteValues
Application.Goto Reference:="R318C50"
Range("BR318:CK318").Copy
Seleccion.Select
Cells(j, 1).PasteSpecial Paste:=xlPasteValues

Next i

Application.ScreenUpdating = True
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True
Application.CutCopyMode = False


End Sub
 
Sort by date Sort by votes
Hello Eric!! Thank you very much for your answer.

Now I'm using the code edited by noir in this topic, I think that it is shorter, but the time spent is similar to what it takes your sheet or that of Hiker.

Code: 
Sub Macro2()

Dim Indices As Worksheet, Calculos As Worksheet, Seleccion As Worksheet
Dim i As Long, j As Long, LastCol As Long

Application.ScreenUpdating = False
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False

Set Indices = Sheets("C.Indices")
Set Calculos = Sheets("CALCULOS")
Set Seleccion = Sheets("Sel.Mes")

LastCol = Indices.Cells(1, Columns.Count).End(xlToLeft).Column

For i = 8 To LastCol

  j = i - 6

  Indices.Columns(i).Copy
  Calculos.Range("D1").PasteSpecial Paste:=xlPasteValues
  Calculos.Range("BR318:CK318").Copy
  Seleccion.Cells(j, 1).PasteSpecial Paste:=xlPasteValues
  
  Application.CutCopyMode = False

Next i

Application.ScreenUpdating = True
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True

End Sub

There in't bug, every column is pasted to D in calculos because there are different formulas refered to that column that give a result in BR318:CK318!!

I haven't understood well haw to make this

And I really believe that you can change this:

Code:

Indices.Columns(i).Copy
Calculos.Range("D1").PasteSpecial Paste:=xlPasteValues

to something like:


Code:
LR = last row of columns(i)
Calculos.Range("D1:D" & lr).Value = Indices.Range(Cells(1, i), Cells(LR, i)).Value

and cut down the remaining time by another 75%.
Click to expand...
 
Last edited:
Upvote 0

Excel Facts

Which Excel functions can ignore hidden rows?
The SUBTOTAL and AGGREGATE functions ignore hidden rows. AGGREGATE can also exclude error cells and more.
I have this problem when I try to do your last recommendation, I supose I'm not doing it well

Code: 
Sub Macro2()

Dim Indices As Worksheet, Calculos As Worksheet, Seleccion As Worksheet
Dim i As Long, j As Long, LastCol As Long, LastRow As Long, LR As Long

Application.ScreenUpdating = False
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False

Set Indices = Sheets("C.Indices")
Set Calculos = Sheets("CALCULOS")
Set Seleccion = Sheets("Sel.Mes")

LastCol = Indices.Cells(1, Columns.Count).End(xlToLeft).Column
LastRow = Indices.Cells(Indices.Rows.Count, "i").End(xlUp).Row
LR = Calculos.Cells(Calculos.Rows.Count, "D").End(xlUp).Row

For i = 8 To LastCol

  j = i - 6

[COLOR=#ff0000][B]   Calculos.Range("D1:D" & LR).Value = Indices.Range(Cells(1, i), Cells(LastRow, i)).Value[/B][/COLOR]
  Calculos.Range("BR318:CK318").Copy
  Seleccion.Cells(j, 1).PasteSpecial Paste:=xlPasteValues
  
  Application.CutCopyMode = False

Next i

Application.ScreenUpdating = True
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True

End Sub
 
Last edited:
Upvote 0
Hello!!

Code: 
Sub [/COLOR]Macro2()[/FONT][/COLOR]
[FONT=Menlo]
[/FONT]
[COLOR=#000000][FONT=Menlo][COLOR=#011993]Dim[/COLOR] Indices [COLOR=#011993]As[/COLOR] Worksheet, Calculos [COLOR=#011993]As[/COLOR] Worksheet, Seleccion [COLOR=#011993]As[/COLOR] Worksheet[/FONT][/COLOR]
[COLOR=#000000][FONT=Menlo][COLOR=#011993]Dim[/COLOR] i [COLOR=#011993]As[/COLOR] [COLOR=#011993]Long[/COLOR], j [COLOR=#011993]As[/COLOR] [COLOR=#011993]Long[/COLOR], LastCol [COLOR=#011993]As[/COLOR] [COLOR=#011993]Long[/COLOR], lRow1 [COLOR=#011993]As[/COLOR] [COLOR=#011993]Long[/COLOR], lRow2 [COLOR=#011993]As[/COLOR] [COLOR=#011993]Long[/COLOR], CalcRange [COLOR=#011993]As[/COLOR] [COLOR=#011993]Variant[/COLOR][/FONT][/COLOR]
[FONT=Menlo]
[/FONT]
[COLOR=#000000][FONT=Menlo]Application.ScreenUpdating = [COLOR=#011993]False[/COLOR][/FONT][/COLOR]
[COLOR=#000000][FONT=Menlo]Application.EnableEvents = [COLOR=#011993]False[/COLOR][/FONT][/COLOR]
[COLOR=#000000][FONT=Menlo]ActiveSheet.DisplayPageBreaks = [COLOR=#011993]False[/COLOR][/FONT][/COLOR]
[FONT=Menlo]
[/FONT]
[COLOR=#000000][FONT=Menlo][COLOR=#011993]Set[/COLOR] Indices = Sheets("C.Indices")[/FONT][/COLOR]
[COLOR=#000000][FONT=Menlo][COLOR=#011993]Set[/COLOR] Calculos = Sheets("CALCULOS")[/FONT][/COLOR]
[COLOR=#000000][FONT=Menlo][COLOR=#011993]Set[/COLOR] Seleccion = Sheets("Sel.Mes")[/FONT][/COLOR]
[FONT=Menlo]
[/FONT]
[COLOR=#000000][FONT=Menlo]LastCol = Indices.Cells(1, Columns.Count).End(xlToLeft).Column[/FONT][/COLOR]
[FONT=Menlo]
[/FONT]
[COLOR=#000000][FONT=Menlo][COLOR=#011993]For[/COLOR] i = 8 [COLOR=#011993]To[/COLOR] LastCol[/FONT][/COLOR]
[FONT=Menlo]
[/FONT]
[COLOR=#000000][FONT=Menlo]  lRow2 = Indices.Cells(1, i).End(xlDown).Row[/FONT][/COLOR]
[COLOR=#000000][FONT=Menlo]  CalcRange = Calculos.Range("BR318:CK318").Value[/FONT][/COLOR]
[COLOR=#000000][FONT=Menlo]  j = i - 6[/FONT][/COLOR]
[FONT=Menlo]
[/FONT]
[COLOR=#000000][FONT=Menlo][COLOR=#ff0000][B]  Calculos.Range(Cells(1, 4), Cells(lRow2, 4)).Value = Indices.Range(Cells(1, i), Cells(lRow2, i)).Value[/B][/COLOR][/FONT][/COLOR]
[COLOR=#000000][FONT=Menlo]  Seleccion.Range("A" & j & ":T" & j).Value = CalcRange[/FONT][/COLOR]

[COLOR=#000000][FONT=Menlo]  Application.CutCopyMode = [COLOR=#011993]False[/COLOR][/FONT][/COLOR]
[FONT=Menlo]
[/FONT]
[COLOR=#011993][FONT=Menlo]Next[COLOR=#000000] i[/COLOR][/FONT][/COLOR]
[FONT=Menlo]
[/FONT]
[COLOR=#000000][FONT=Menlo]Application.ScreenUpdating = [COLOR=#011993]True[/COLOR][/FONT][/COLOR]
[COLOR=#000000][FONT=Menlo]Application.EnableEvents = [COLOR=#011993]True[/COLOR][/FONT][/COLOR]
[COLOR=#000000][FONT=Menlo]ActiveSheet.DisplayPageBreaks = [COLOR=#011993]True[/COLOR][/FONT][/COLOR]
[FONT=Menlo]
[/FONT]
[COLOR=#011993][FONT=Menlo]EndSub[/FONT][/COLOR]


This code doesn't work, any idea to fix it??
 
Last edited:
Upvote 0
Only on my phone and so hopefully I haven't made any typos but try...

Code: 
With Calculos.Range(Cells(1, 4), Cells(lRow2, 4))
Indices.Cells(1, i).Resize(.Rows.Count, .Column.Count).Value = .Value
End With
 
Upvote 0
I am just starting with macros :/ , where do I have to copy and paste that code inside mine?? Thank you very much for your answer
 
Last edited:
Upvote 0
First of all problem with posting on my phone, I had the ranges the wrong way around :(
Should be...
Code: 
With Indices.Range(Indices.Cells(1, i), Indices.Cells(lRow2, i)).Value
Calculos.Cells(1, 4).Resize(.Rows.Count, .Columns.Count).Value = .Value
End With

and it replaces your red line. Please note the extra Indices else it references the active sheet.
 
Last edited:
Upvote 0
Hello again mark!

If I understand you, with your change my final code is this one:

Code: 
[COLOR=#011993][FONT=Menlo]Sub Macro2()[/FONT][/COLOR]
[COLOR=#011993][FONT=Menlo]
[/FONT][/COLOR]
[COLOR=#011993][FONT=Menlo]Dim Indices As Worksheet, Calculos As Worksheet, Seleccion As Worksheet[/FONT][/COLOR]
[COLOR=#011993][FONT=Menlo]Dim i As Long, j As Long, LastCol As Long, lRow As Long, CalcRange As Variant[/FONT][/COLOR]
[COLOR=#011993][FONT=Menlo]
[/FONT][/COLOR]
[COLOR=#011993][FONT=Menlo]Application.ScreenUpdating = False
Application.DisplayStatusBar = False[/FONT][/COLOR]
[COLOR=#011993][FONT=Menlo]Application.EnableEvents = False[/FONT][/COLOR]
[COLOR=#011993][FONT=Menlo]ActiveSheet.DisplayPageBreaks = False[/FONT][/COLOR]
[COLOR=#011993][FONT=Menlo]
[/FONT][/COLOR]
[COLOR=#011993][FONT=Menlo]Set Indices = Sheets("C.Indices")[/FONT][/COLOR]
[COLOR=#011993][FONT=Menlo]Set Calculos = Sheets("CALCULOS")[/FONT][/COLOR]
[COLOR=#011993][FONT=Menlo]Set Seleccion = Sheets("Sel.Mes")[/FONT][/COLOR]
[COLOR=#011993][FONT=Menlo]
[/FONT][/COLOR]
[COLOR=#011993][FONT=Menlo]LastCol = Indices.Cells(1, Columns.Count).End(xlToLeft).Column[/FONT][/COLOR]
[COLOR=#011993][FONT=Menlo]
[/FONT][/COLOR]
[COLOR=#011993][FONT=Menlo]For i = 8 To LastCol[/FONT][/COLOR]
[COLOR=#011993][FONT=Menlo]
[/FONT][/COLOR]
[COLOR=#011993][FONT=Menlo]  CalcRange = Calculos.Range("BR318:CK318").Value[/FONT][/COLOR]
[COLOR=#011993][FONT=Menlo]  lRow = Indices.Cells(1, i).End(xlDown).Row[/FONT][/COLOR]
[COLOR=#011993][FONT=Menlo]  j = i - 6[/FONT][/COLOR]
[COLOR=#011993][FONT=Menlo]
[/FONT][/COLOR]
[COLOR=#011993][FONT=Menlo]  With Indices.Range(Indices.Cells(1, i), Indices.Cells(lRow, i)).Value[/FONT][/COLOR]
[COLOR=#000000][FONT=Menlo][COLOR=#ff0000][B]  Calculos.Cells(1, 4).Resize(.Rows.Count, .Columns.Count).Value = .Value[/B][/COLOR][/FONT][/COLOR]
[COLOR=#ff0000][/COLOR][COLOR=#011993][FONT=Menlo]  End With[/FONT][/COLOR]
[COLOR=#011993][FONT=Menlo]  Seleccion.Range("A" & j & ":T" & j).Value = CalcRange[/FONT][/COLOR]
[COLOR=#011993][FONT=Menlo]  
  Application.CutCopyMode = False[/FONT][/COLOR]
[COLOR=#011993][FONT=Menlo]
[/FONT][/COLOR]
[COLOR=#011993][FONT=Menlo]Next i[/FONT][/COLOR]
[COLOR=#011993][FONT=Menlo]
[/FONT][/COLOR]
[COLOR=#011993][FONT=Menlo]Application.ScreenUpdating = True[/FONT][/COLOR]
[COLOR=#011993][FONT=Menlo]Application.EnableEvents = True
Application.DisplayStatusBar = statusBarState[/FONT][/COLOR]
[COLOR=#011993][FONT=Menlo]ActiveSheet.DisplayPageBreaks = True[/FONT][/COLOR]
[COLOR=#011993][FONT=Menlo]
[/FONT][/COLOR]
[COLOR=#011993][FONT=Menlo]End Sub[/FONT][/COLOR]

Now error is there, It still doesn't work
 
Upvote 0
Sorry, take off the .Value on

Code: 
 Indices.Cells(lRow, i)).Value
 
Upvote 0
Now the macro works up to 3 times faster!!! Thank you very much!!

But there is a huge problem that I think you can fix, otherwise it is unuseful: in the end of the macro, when I go to sheet "Selection", I have the same values in all of the rows. Before that change I had different values in each row, it is as if "Calculos" sheet doesn't apply the formulas of the sheet for each "i" that is pasted there
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Question
another way to speed the macro .
Replies
3
Views
515
Georgiboy
Georgiboy
E
  • Question
Help Cleaning Up / Optimizing VBA Code
Replies
6
Views
284
offthelip
O
F
  • Question
VBA Import columns by headers - Need prompts to select workbook/sheet name
Replies
2
Views
189
floggingmolly
F
R
  • Question
Save As does not work properly
Replies
7
Views
811
Rainmanne
R
R
  • Solved
Code Opens File but Isn't Closing It
Replies
4
Views
288
reberryjr
R

Forum statistics

Threads
1,215,059
Messages
6,122,918
Members
449,094
Latest member
teemeren

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