How can I make this run faster?

Dummy Excel

Well-known Member
Joined
Sep 21, 2005
Messages
1,004
Office Version
  1. 2019
  2. 2010
  3. 2007
Platform
  1. Windows
HI All,
My data can vary from 40k rows to 100k rows (im using xl07) - Can someone help me to speed up the macro?

my code is:
Code:
    'Formatting APN
    Columns("C:C").Select
    Selection.NumberFormat = "0"
    Range("A1").Select
    
    'Creating Style Colour column
    Columns("H:H").Select
    Selection.Insert Shift:=xlToRight
    Selection.Insert Shift:=xlToRight
    Range("H1").Select
    ActiveCell.FormulaR1C1 = "Style Colour"
    Range("H2").Select
    ActiveCell.FormulaR1C1 = "=RC[-4]&RC[-3]"
    Range("H2").Select
    Selection.Copy
    Range("G2").End(xlDown).Offset(0, 1).Select
    Range(Selection, Selection.End(xlUp)).Select
    ActiveSheet.Paste
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    'Creating SKU column
    Range("I1").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "SKU"
    Range("I2").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(RC[-3]=""N/A"",RC[-5]&RC[-4]&RC[-2],IF(RC[-2]=""N/A"",RC[-5]&RC[-4]&RC[-3],RC[-5]&RC[-4]&RC[-3]&RC[-2]))"
    Range("I2").Select
    Selection.Copy
    Range("h2").End(xlDown).Offset(0, 1).Select
    Range(Selection, Selection.End(xlUp)).Select
    ActiveSheet.Paste
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    
    'creating total at end
    Range("DL1").Select
    ActiveCell.FormulaR1C1 = "Total"
    With ActiveCell.Characters(Start:=1, Length:=5).Font
        .Name = "Arial"
        .FontStyle = "Regular"
        .Size = 10
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    Range("DL2").Select
    ActiveCell.FormulaR1C1 = "=SUM(RC[-52]:RC[-1])"
    Range("DL2").Select
    Selection.Copy
    Range("DK1").End(xlDown).Offset(0, 1).Select
    Range(Selection, Selection.End(xlUp)).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    
    'sets autofilter
    Range("a1").Select
    Selection.AutoFilter
    Range("a1").Select
    
    'adds columns for months - first year
    Columns("P:P").Select
    Selection.Insert Shift:=xlToRight
    Range("P1").Select
    ActiveCell.FormulaR1C1 = "Jan"
    Columns("U:U").Select
    Selection.Insert Shift:=xlToRight
    Range("U1").Select
    ActiveCell.FormulaR1C1 = "Feb"
    Columns("Z:Z").Select
    Selection.Insert Shift:=xlToRight
    Range("Z1").Select
    ActiveCell.FormulaR1C1 = "Mar"
    Columns("AE:AE").Select
    Selection.Insert Shift:=xlToRight
    Range("AE1").Select
    ActiveCell.FormulaR1C1 = "Apr"
    Columns("AJ:AJ").Select
    Selection.Insert Shift:=xlToRight
    Range("AJ1").Select
    ActiveCell.FormulaR1C1 = "May"
    Columns("AO:AO").Select
    Selection.Insert Shift:=xlToRight
    Range("AO1").Select
    ActiveCell.FormulaR1C1 = "Jun"
    Columns("AT:AT").Select
    Selection.Insert Shift:=xlToRight
    Range("AT1").Select
    ActiveCell.FormulaR1C1 = "Jul"
    Columns("AY:AY").Select
    Selection.Insert Shift:=xlToRight
    Range("AY1").Select
    ActiveCell.FormulaR1C1 = "Aug"
    Columns("BD:BD").Select
    Selection.Insert Shift:=xlToRight
    Range("BD1").Select
    ActiveCell.FormulaR1C1 = "Sep"
    Columns("BI:BI").Select
    Selection.Insert Shift:=xlToRight
    Range("BI1").Select
    ActiveCell.FormulaR1C1 = "Oct"
    Columns("BN:BN").Select
    Selection.Insert Shift:=xlToRight
    Range("BN1").Select
    ActiveCell.FormulaR1C1 = "Nov"
    Columns("BS:BS").Select
    Selection.Insert Shift:=xlToRight
    Range("BS1").Select
    ActiveCell.FormulaR1C1 = "Dec"
    Columns("BX:BX").Select
    Selection.Insert Shift:=xlToRight
    
    'second year
    Columns("CC:CC").Select
    Selection.Insert Shift:=xlToRight
    Range("CC1").Select
    ActiveCell.FormulaR1C1 = "Jan"
    Columns("CH:CH").Select
    Selection.Insert Shift:=xlToRight
    Range("CH1").Select
    ActiveCell.FormulaR1C1 = "Feb"
    Columns("CM:CM").Select
    Selection.Insert Shift:=xlToRight
    Range("CM1").Select
    ActiveCell.FormulaR1C1 = "Mar"
    Columns("CR:CR").Select
    Selection.Insert Shift:=xlToRight
    Range("CR1").Select
    ActiveCell.FormulaR1C1 = "Apr"
    Columns("CW:CW").Select
    Selection.Insert Shift:=xlToRight
    Range("CW1").Select
    ActiveCell.FormulaR1C1 = "May"
    Columns("DB:DB").Select
    Selection.Insert Shift:=xlToRight
    Range("DB1").Select
    ActiveCell.FormulaR1C1 = "Jun"
    Columns("DG:DG").Select
    Selection.Insert Shift:=xlToRight
    Range("DG1").Select
    ActiveCell.FormulaR1C1 = "Jul"
    Columns("DL:DL").Select
    Selection.Insert Shift:=xlToRight
    Range("DL1").Select
    ActiveCell.FormulaR1C1 = "Aug"
    Columns("DQ:DQ").Select
    Selection.Insert Shift:=xlToRight
    Range("DQ1").Select
    ActiveCell.FormulaR1C1 = "Sep"
    Columns("DV:DV").Select
    Selection.Insert Shift:=xlToRight
    Range("DV1").Select
    ActiveCell.FormulaR1C1 = "Oct"
    Columns("EA:EA").Select
    Selection.Insert Shift:=xlToRight
    Range("EA1").Select
    ActiveCell.FormulaR1C1 = "Nov"
    Columns("EF:EF").Select
    Selection.Insert Shift:=xlToRight
    Range("EF1").Select
    ActiveCell.FormulaR1C1 = "Dec"

End Sub
thanks
Sam
 
What takes so long, calculating the formulas?

I see a lot of selecting there, you almost dont have to ever select a range to work with it. Not sure that would help speed things along though.
 
Upvote 0
Remove the selects and selections.

Example:

Code:
    Range("DL2").Select
    Selection.Copy

becomes
Code:
    Range("DL2").Copy

Do this throughout all the code and it will have a massive impact.

Also because the formulas are calculating each time you change a cell, put this at the start:
Code:
Application.Calculation = xlCalculationManual
And this at the end:
Code:
Application.Calculation = xlCalculationAutomatic
 
Upvote 0
in addition to that try adding at the beginning :
Code:
application.screenupdating = false

and this at the end
Code:
application.screenupdating = true
 
Upvote 0
Thanks guys
is there a better way to do all the inserting of a new column? A new column needs to be added for every fourth columns (for each week in a month)?
 
Upvote 0
You could use something along the lines of:

Code:
Dim MonthName As Variant
MonthName = Array("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")
For X = 1 To 12
    Cells(2, X + 11 + (X * 4)).Formula = MonthName(X - 1)
    Cells(2, X + 76 + (X * 4)).Formula = MonthName(X - 1)
Next

this puts the months in the same places your code did but without seeing the sheet or the codes application I am just guessing what you need it to do.

Can you post some sample data?

Cheers

Dan
 
Upvote 0
you could try

Code:
j = 1
For i = 1 To 140 Step 5
    Columns(i).Insert Shift:=xlToRight
    Cells(1, i) = Left(MonthName(j), 3)
    j = j + 1
    If j = 13 Then
        j = 1
        i = i + 5
    End If
Next i
 
Upvote 0
Actually, even better, drop the array altogether:

Code:
Sub Temp()
For X = 1 To 12
    Cells(2, X + 11 + (X * 4)).Formula = Format("1/" & X & "/08", "Mmm")
    Cells(2, X + 76 + (X * 4)).Formula = Format("1/" & X & "/08", "Mmm")
Next
End Sub

Note, if you are in the US this will probably need to be changed round to account for your date settings.
 
Last edited:
Upvote 0
I would also reccomend you don't put a sum column all the way down to row 65,536. Can you anticipate how many rows of data there will be?
 
Upvote 0
zzjasonzz - your way does work, although it actually places jan/feb in row 2 of the data, it actually doesnt insert a new row.

BH - your second post results the same way as zzjasonzz

To answer your question BH, I was going to use the xldown function with an offset to find the last cell and do the total that way - Is there a better way?

thanks both for your patience
 
Upvote 0

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