How can I make this run faster?

D

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
 
Sort by date Sort by votes
So is this setting up a template or is there data in there to begin with which is why you insert columns?

Not finished yet but the code is so far looking like this:

Code: 
Sub Temp()
For X = 1 To 12
    'Columns(X + 11 + (X * 4)).Insert Shift:=xlToRight ' Need to work out if an insert is necesary
    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
    'Creating SKU column
    Range("I1").FormulaR1C1 = "SKU"
    Range("I2").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]))"
    'Creating Style Colour column
    Range("H1").FormulaR1C1 = "Style Colour"
    Range("H2").FormulaR1C1 = "=RC[-4]&RC[-3]"
    'Formatting APN
    Columns("C:C").NumberFormat = "0"
    'sets autofilter
    Range("a1").AutoFilter
End Sub
 
Upvote 0

Excel Facts

How can you turn a range sideways?
Copy the range. Select a blank cell. Right-click, Paste Special, then choose Transpose.
BH this is running a lot quicker - there are 2 issues though:
1) when you add the columns for the Style Colour, SKU, & months, it is not inserting a new column, it is placing the months in row 2..although you can see the headers for Style Colour & SKU it has overridden the data that was there.

here is a snapshot:
raw data.xlsx
ABCDEFGHIJKLMNOP
1AFCORPAFDEPTAFAPNAFSTYLEAFCOLOURAFDIMENSAFSIZEStyleColourSKUIHSH01IHSH02IHSH03IHSH04IHSH05IHSH06IHSH07
2abc452123456789123GRE102S123GRE123GRE102S000000Jan
3abc452234567891456GRE102S12520072222222
4abc452345678912789GRE102S12620062222222
Raw Data template


2) I need Jan to start in column N and then every 4 columns insert a new column for the next month. Also after Dec, after 4 columns, can we add in a blank column?

thanks for your help
Sam
 
Upvote 0
OK, Try this:

Code: 
Sub Temp()
For X = 1 To 12
    Columns(X + 9 + (X * 4)).Insert Shift:=xlToRight
    Cells(1, X + 9 + (X * 4)).Formula = Format("1/" & X & "/08", "Mmm")
    Columns((X * 2) + 57 + (X * 4)).Insert Shift:=xlToRight
    Cells(1, (X * 2) + 57 + (X * 4)).Formula = Format("1/" & X & "/08", "Mmm")
Next
    Columns(134).Insert Shift:=xlToRight
    Cells(1, 134).Formula = "Total"
    'Creating SKU column
    Range("I1").FormulaR1C1 = "SKU"
    Range("I2").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]))"
    'Creating Style Colour column
    Range("H1").FormulaR1C1 = "Style Colour"
    Range("H2").FormulaR1C1 = "=RC[-4]&RC[-3]"
    'Formatting APN
    Columns("C:C").NumberFormat = "0"
    'sets autofilter
    Range("a1").AutoFilter
End Sub

Next we can work on whatever you want the totals to do. Do you want each month to sum the previous four columns and the total to sum all the months?

Cheers

Dan
 
Upvote 0
this is working well - only problem is the Style Colur and SKU still arent inserting a new column
 
Upvote 0
Code: 
Sub Temp()
For X = 1 To 12
    Columns(X + 9 + (X * 4)).Insert Shift:=xlToRight
    Cells(1, X + 9 + (X * 4)).Formula = Format("1/" & X & "/08", "Mmm")
    Columns((X * 2) + 57 + (X * 4)).Insert Shift:=xlToRight
    Cells(1, (X * 2) + 57 + (X * 4)).Formula = Format("1/" & X & "/08", "Mmm")
Next
    Columns(134).Insert Shift:=xlToRight
    Cells(1, 134).Formula = "Total"
    'Creating SKU column
    Columns(9).Insert Shift:=xlToRight
    Range("I1").FormulaR1C1 = "SKU"
    Range("I2").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]))"
    'Creating Style Colour column
    Columns(8).Insert Shift:=xlToRight
    Range("H1").FormulaR1C1 = "Style Colour"
    Range("H2").FormulaR1C1 = "=RC[-4]&RC[-3]"
    'Formatting APN
    Columns("C:C").NumberFormat = "0"
    'sets autofilter
    Range("a1").AutoFilter
End Sub

The only addition is:

Columns(9).Insert Shift:=xlToRight

and

Columns(8).Insert Shift:=xlToRight


Cheers

Dan
 
Upvote 0
Hi Dan
thanks for your patience and help
Below is my code - I have made some changes and have added more code.
Code: 
    Application.Calculation = xlCalculationManual
    
    'sets totals
    Range("I1").End(xlDown).Offset(2, 0).Select
    ActiveCell.FormulaR1C1 = "Total 2006"
    Range("I1").End(xlDown).Offset(3, 0).Select
    ActiveCell.FormulaR1C1 = "Total 2007"
    
    Range("J1").End(xlDown).Offset(2, 0).Select
    ActiveCell.FormulaR1C1 = _
        "=SUMPRODUCT(SUBTOTAL(9,OFFSET(R[-32140]C,ROW(R[-32140]C:R[-2]C)-ROW(R[-32140]C),0)),(R2C9:R32140C9 = 2006)+0)"
    Range("J1").End(xlDown).Offset(3, 0).Select
    ActiveCell.FormulaR1C1 = _
        "=SUMPRODUCT(SUBTOTAL(9,OFFSET(R[-32141]C,ROW(R[-32141]C:R[-3]C)-ROW(R[-32141]C),0)),(R2C9:R32140C9 = 2007)+0)"
    Range(Selection, Selection.End(xlUp)).Select
    Selection.Copy
    
    With Range(Cells(Rows.Count, "K").End(xlUp).Offset(2), Cells(Rows.Count, "DH").End(xlUp).Offset(1))
        .Offset(1).Resize(, 103).Select
    End With
    
    ActiveSheet.Paste
    Application.CutCopyMode = False
    
    
    'adds columns for 13 months
    For X = 1 To 13
        Columns(X + 9 + (X * 4)).Insert Shift:=xlToRight
        Cells(1, X + 9 + (X * 4)).Formula = Format("1/" & X & "/08", "Mmm")
        Columns((X * 2) + 61 + (X * 4)).Insert Shift:=xlToRight
        Cells(1, (X * 2) + 61 + (X * 4)).Formula = Format("1/" & X & "/08", "Mmm")
    Next
    Columns(140).Insert Shift:=xlToRight
    Cells(1, 140).Formula = "Total"
    Range("EJ2").Select
    ActiveCell.FormulaR1C1 = "=SUM(RC[-55]:RC[-2])"
    Range("EJ2").Copy
    Range("EH1").End(xlDown).Offset(0, 2).Select
    Range(Selection, Selection.End(xlUp)).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False

    Application.Calculation = xlCalculationAutomatic
    
    'Creating Style Colour column
    Columns(8).Insert Shift:=xlToRight
    Range("H1").FormulaR1C1 = "Style Colour"
    Range("H2").FormulaR1C1 = "=RC[-4]&RC[-3]"
    Range("H2").Copy
    Range("G1").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 SKU column
    Columns(9).Insert Shift:=xlToRight
    Range("I1").FormulaR1C1 = "SKU"
    Range("I2").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").Copy
    Range("h1").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
    
    'Formatting APN
    Columns("C:C").NumberFormat = "0"
    'sets autofilter
    Range("a1").AutoFilter

Is there anyway that the code for 'Creating Style Colour column & 'Creating SKU column can be run any quicker?

Also, this is a weekly report, therefore the number of rows will vary from week to week - all columns remain the same.
Is there a way that my code below can take into account the number of different rows each week?
Code: 
"=SUMPRODUCT(SUBTOTAL(9,OFFSET(R[-32140]C,ROW(R[-32140]C:R[-2]C)-ROW(R[-32140]C),0)),(R2C9:R32140C9 = 2006)+0)"

thanks
Sam
 
Upvote 0
Mate, first off, you really need to stop doing this:

Range("I1").End(xlDown).Offset(2, 0).Select
ActiveCell.FormulaR1C1 = "Total 2006"
Range("I1").End(xlDown).Offset(3, 0).Select
ActiveCell.FormulaR1C1 = "Total 2007"

Think of it as a cup of tea. You don't need to pick the cup up before you pour the hot water in, you can just pour it in without actually having to interact with the cup so long as you know it is there :).

Selecting is so time consuming in the Excel app. To change it all you do is delete the select and delete the object so it becomes one line. Like so:

Range("I1").End(xlDown).Offset(2, 0).FormulaR1C1 = "Total 2006"
Range("I1").End(xlDown).Offset(3, 0).FormulaR1C1 = "Total 2007"

This way the app is not wasting time selecting something that it doesn't need to. To be honest, I cannot remember the last time I found a genuine need to select a cell for automated manipulation.

Where you have selection.copy and selection.paste you can change that too to Range("Cell_to_paste_to").formula = Range("cell_to_copy").value or .text or whatever aspect you want to copy. This saves time and again, no need to select anything.

I am popping out to lunch. Have a bash at it with my suggestions and when I get back if you have any problems I will do my best to fix it up for you :).

Cheers

Dan

Edit: Just noticed this too: Range("I1").End(xlDown)

Its better to come from the bottom up than the top down. This way you avoid the blanks if there are any. Something along the lines of Range("I" & Rows.Count).End(xlUp).Row works well :).
 
Last edited:
Upvote 0
hi Dan
I really appreciate your help with this - the cup of tea really makes perfect sense, I will remember that - I just need to rewrite all my macros!!
The problem I have about going from the bottom up is that it changes the header row. Is there a way that I can for from bottom to top without overridding the header row?

thanks
Sam
 
Upvote 0
Range("I" & Rows.Count).End(xlUp).Offset(2, 0).Formula = "Total 2006"
Range("I" & Rows.Count).End(xlUp).Offset(3, 0).Formula = "Total 2007"

I reckon that should do it nicely ;)

When we go from the bottom up, we are not going from the bottom of the data up but from the bottom of the sheet. In Excel prior to the current version, this was from row 65536 upwards, now Excel supports over a million rows so it would go from that last row upwards until it hits data.

What this does is make sure that you are at the end of your data. using XLDown, if you have a blank anywhere in Column I it is going to this that that is the end of the data and put the "Total 2006" 2 cells lower overwriting any data that happens to be there already.

Cheers

Dan
 
Last edited:
Upvote 0
Hi Dave
Sorry its taken so long to reply - boss made me put this urgent priority on hold to work on another urgent priority!!

Yes I understand what you mean re: Range("I" & Rows.Count).End(xlUp).Offset(3, 0).Formula = "Total 2007"

The problem I am still having is the sumproduct formula. How can this be rewritten so the cells arent hard coded?
Code: 
"=SUMPRODUCT(SUBTOTAL(9,OFFSET(R[-32140]C,ROW(R[-32140]C:R[-2]C)-ROW(R[-32140]C),0)),(R2C9:R32140C9 = 2006)+0)"

thanks
Sam
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Question Question
VBA removing heading in spreadsheet
Replies
3
Views
273
rlv01
R
S
  • Question Question
Macro Formatting to all WS
Replies
4
Views
360
MARK858
MARK858
J
  • Question Question
VBA or formula to move data in last used column to column A
Replies
5
Views
229
Peter_SSs
Peter_SSs
P
  • Question Question
Help with Vba Code
Replies
3
Views
478
Coyotex3
C
Sean15
  • Question Question
Could you help improve recorded macro
2
Replies
13
Views
474
Sean15
Sean15

Forum statistics

Threads
1,224,845
Messages
6,181,300
Members
453,031
Latest member
Chris_1

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