How to speed up a macro handling a large amount of data?

J

jacksongf

New Member
Joined
Mar 23, 2017
Messages
21
Here is my whole code. A lot of it is very similar, just using different variables, but I kept it in for context. It's dealing with around 210,000 rows, and 11 columns, 7 of which are in-macro formulas (see bottom of code) which are copied then pasted as values. Basically, it was fairly fast (~20seconds), until I implemented the formula step. Now it takes over 2 minutes. It works (no error codes), but it's just too slow to be practical.

The last sub (Formulas) and then the part after the "Call Formulas" is where it really slows down I think.

It would be a huge help if someone could help me with some tips to optimize this code and make it faster, especially in the formulas section.
If there are any other pointers, I'm all ears, as I'm relatively inexperienced with VBA coding.

Thanks in advance!


Code: 
Option Explicit

Public MyRowCount, i, Last, LR, j, AnswerP, AnswerD, ProdColVar, ProdRowVar, DistColVar, DistRowVar, NumDistRows, NumDistCols, NumProdRows, NumProdCols As Long
Public DataSheet, DistSheet, ProdSheet As Worksheet
Public TempWB As Workbook
Public rList, RNG As Range
Public TBL As ListObject
Public newTbl As String
__________________________________________________________________________________________________________

Sub CopyPasteData()

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.EnableCancelKey = xlDisabled

Set DistSheet = Sheets("Distribution")
Set ProdSheet = Sheets("Production")
Set DataSheet = Sheets("Data")

NumDistRows = DistSheet.Cells(Rows.Count, 1).End(xlUp).Row - 17
NumDistCols = DistSheet.Cells(17, Columns.Count).End(xlToLeft).Column
NumProdRows = ProdSheet.Cells(Rows.Count, 1).End(xlUp).Row - 17
NumProdCols = ProdSheet.Cells(17, Columns.Count).End(xlToLeft).Column

DistRowVar = NumDistRows
DistColVar = NumDistCols - 3
ProdRowVar = NumProdRows
ProdColVar = NumProdCols - 3

MyRowCount = (DistRowVar * DistColVar) + (ProdRowVar * ProdColVar)


DataSheet.Activate
    With DataSheet.ListObjects("Data")
        Set rList = .Range
        .Unlist     'converts "Data" table to a range
    End With

DataSheet.Range(Cells(2, 1), Cells(MyRowCount, 11)).ClearContents


    Call CopyPasteAccountCodeD
    Call CopyPasteLocationD
    Call CopyPasteLocationNumD
    Call CopyPasteValuesD
    Call CopyPasteAccountCodeP
    Call CopyPasteLocationP
    Call CopyPasteLocationNumP
    Call CopyPasteValuesP
    Call Formulas


DataSheet.UsedRange.Columns("E:K").Calculate

DataSheet.Range(Cells(2, 5), Cells(MyRowCount, 11)).Copy
DataSheet.Range(Cells(2, 5), Cells(MyRowCount, 11)).PasteSpecial xlPasteValues         'Eliminates all formulas in range
Application.CutCopyMode = False

DataSheet.Activate
DataSheet.Cells.ClearFormats

Set RNG = DataSheet.Range(Range("A1"), Range("A1").SpecialCells(xlLastCell))    'converts range to table
Set TBL = DataSheet.ListObjects.Add(xlSrcRange, rng, , xlYes)

    TBL.TableStyle = "TableStyleMedium2"

    newTbl = "Data"

    With ActiveSheet
        .ListObjects(1).Name = newTbl      'changes name of table to "Data"
    End With

Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic

MsgBox "Code Complete"

End Sub

______________________________________________________________________________________________

Sub CopyPasteAccountCodeD()

DistRowVar = NumDistRows
DistColVar = NumDistCols - 3
AnswerD = DistRowVar * DistColVar

DistSheet.Activate
DistSheet.Range(Cells(17, 4), Cells(17, NumDistCols)).Copy

    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        Selection.Copy
        .Cells(3, 1).PasteSpecial Transpose:=True
        Selection.Copy
    End With

DataSheet.Activate
DataSheet.Range(Cells(2, 3), Cells(AnswerD + 1, 3)).Select
DataSheet.Paste

    Application.CutCopyMode = False
    TempWB.Close savechanges:=False

End Sub

____________________________________________________________________________________________

Sub CopyPasteLocationD()

    For j = 0 To (NumDistRows - 1)

        DistSheet.Activate
        DistSheet.Cells(18 + j, 1).Copy

        LR = DataSheet.Range("A" & Rows.Count).End(xlUp).Offset(1).Row

        DataSheet.Activate
        DataSheet.Range(Cells(LR, 1), Cells(LR + (DistColVar - 1), 1)).Select
        DataSheet.Paste

    Next j
    
Application.CutCopyMode = False

End Sub

_______________________________________________________________________________________________

Sub CopyPasteLocationNumD()

    For j = 0 To (NumDistRows - 1)

        DistSheet.Activate
        DistSheet.Cells(18 + j, 2).Copy

        LR = DataSheet.Range("B" & Rows.Count).End(xlUp).Offset(1).Row

        DataSheet.Activate
        DataSheet.Range(Cells(LR, 2), Cells(LR + (DistColVar - 1), 2)).Select
        DataSheet.Paste

    Next j

Application.CutCopyMode = False

End Sub

____________________________________________________________________________________________

Sub CopyPasteValuesD()

For j = 0 To (NumDistRows - 1)

        DistSheet.Activate
        DistSheet.Range(Cells(18 + j, 4), Cells(18 + j, NumDistCols)).Copy
        

        LR = DataSheet.Range("D" & Rows.Count).End(xlUp).Offset(1).Row

        DataSheet.Activate
        DataSheet.Range(Cells(LR, 4), Cells(LR + (DistColVar - 1), 4)).Select
        Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True

    Next j

Application.CutCopyMode = False

End Sub

_____________________________________________________________________________________________

Sub CopyPasteAccountCodeP()

ProdRowVar = NumProdRows
ProdColVar = NumProdCols - 3
AnswerP = ProdRowVar * ProdColVar

ProdSheet.Activate
ProdSheet.Range(Cells(17, 4), Cells(17, NumProdCols)).Copy

    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        Selection.Copy
        .Cells(3, 1).PasteSpecial Transpose:=True
        Selection.Copy
    End With

DataSheet.Activate
DataSheet.Range(Cells(AnswerD + 2, 3), Cells(AnswerD + AnswerP + 1, 3)).Select
DataSheet.Paste

    Application.CutCopyMode = False
    TempWB.Close savechanges:=False

End Sub

_________________________________________________________________________________________________

Sub CopyPasteLocationP()

    For j = 0 To (NumProdRows - 1)

        ProdSheet.Activate
        ProdSheet.Cells(18 + j, 1).Copy

        LR = DataSheet.Range("A" & Rows.Count).End(xlUp).Offset(1).Row

        DataSheet.Activate
        DataSheet.Range(Cells(LR, 1), Cells(LR + (ProdColVar - 1), 1)).Select
        DataSheet.Paste

    Next j
    
Application.CutCopyMode = False

End Sub

_______________________________________________________________________________________________

Sub CopyPasteLocationNumP()

    For j = 0 To (NumProdRows - 1)

        ProdSheet.Activate
        ProdSheet.Cells(18 + j, 2).Copy

        LR = DataSheet.Range("B" & Rows.Count).End(xlUp).Offset(1).Row

        DataSheet.Activate
        DataSheet.Range(Cells(LR, 2), Cells(LR + (ProdColVar - 1), 2)).Select
        DataSheet.Paste

    Next j

Application.CutCopyMode = False

End Sub

_____________________________________________________________________________________

Sub CopyPasteValuesP()

For j = 0 To (NumProdRows - 1)

        ProdSheet.Activate
        ProdSheet.Range(Cells(18 + j, 4), Cells(18 + j, NumProdCols)).Copy
        

        LR = DataSheet.Range("D" & Rows.Count).End(xlUp).Offset(1).Row

        DataSheet.Activate
        DataSheet.Range(Cells(LR, 4), Cells(LR + (ProdColVar - 1), 4)).Select
        Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True

    Next j

Application.CutCopyMode = False

End Sub

__________________________________________________________________________________________

Sub Formulas()

Last = DataSheet.Range("A1048576").End(xlUp).Row

    For i = 1 To Last - 1

        DataSheet.Cells(i + 1, 5).Value = "=INDEX(Table2[Category],MATCH(MID(Data!C" & i + 1 & ",4,3),Table2[Abbreviation],0))"
        DataSheet.Cells(i + 1, 6).Value = "=LEFT(Data!C" & i + 1 & ",3)"
        DataSheet.Cells(i + 1, 7).Value = "=INDEX(Table2[Department],MATCH(MID(Data!C" & i + 1 & ",4,3),Table2[Abbreviation],0))"
        DataSheet.Cells(i + 1, 8).Value = "=MID(Data!C" & i + 1 & ",7,3)"
        DataSheet.Cells(i + 1, 9).Value = "=""20"" & RIGHT(Data!C" & i + 1 & ",2)"
        DataSheet.Cells(i + 1, 10).Value = "=VLOOKUP(Data!B" & i + 1 & ",Locations,3,0)"
        DataSheet.Cells(i + 1, 11).Value = "=VLOOKUP(Data!B" & i + 1 & ",Locations,4,0)"
        
    Next i

End Sub
 

Excel Facts

Excel motto
Not everything I do at work revolves around Excel. Only the fun parts.
Sort by date Sort by votes
HI Jack,

Just one quick suggestions.
Formulas will take more time to calculate if you are using entire column reference for example, vlookup(a1,P:Q,2,0) uses full column and vlookup(a1,P1:Q50,2,0) uses only 50 rows reference.

Regards,
DILIPandey
 
Upvote 0
Welcome to the Forum!

There are probably quite a few things you could do to speed up your code. Here's a couple:

1. Avoid looping whenever possible. For example, rather than looping through the rows in Sub Formulas, you could do this:

Code: 
Last = DataSheet.Range("A" & Rows.Count).End(xlUp).Row

With DataSheet.Range("E2:K" & Last)
    .Columns(1).Formula = "=INDEX(Table2[Category],MATCH(MID(C2,4,3),Table2[Abbreviation],0))"""
    .Columns(2).Formula = "=LEFT(C2,3)"
    .Columns(3).Formula = "=INDEX(Table2[Department],MATCH(MID(C2,4,3),Table2[Abbreviation],0))"
    '... etc
    .Value = .Value 'I think you copy/paste values later?
End With

2. It's quicker to work with arrays in VBA than reading/writing to Excel cell by cell. So, for example, you could speed up Sub CopyPasteValuesD like this:

Code: 
Dim vIn As Variant, vOut() As Variant
Dim lCount As Long, r As Long, c As Long
Const START_ROW = 18
Const START_COL = 4

vIn = DistSheet.Cells(START_ROW, START_COL).Resize(NumDistRows, DistColVar).Value
ReDim vOut(1 To UBound(vIn) * UBound(vIn, 2), 1 To 1)
    
For r = 1 To UBound(vIn)
    For c = 1 To UBound(vIn, 2)
        lCount = lCount + 1
        vOut(lCount, 1) = vIn(r, c)
    Next c
Next r

With DataSheet
    LR = .Range("D" & Rows.Count).End(xlUp).Offset(1).Row
    .Cells(LR, START_COL).Resize(UBound(vOut)).Value = vOut
End With

3. Avoid .Activate, .Select, .Selection, .ActiveSheet etc whenever possible. It's inefficient, slow, and rarely necessary.

Code: 
'For example, instead of ...
Sheet1.Activate
Range("A1").Select
Selection.Copy
Sheet2.Activate
Range("A1").Select
ActiveSheet.Paste

'you can simply say
Sheet1.Range("A1").Copy Destination:=Sheet2.Range("A1")
'or in short form
Sheet1.Range("A1").Copy Sheet2.Range("A1")

4. You have declared your variables, which is good practice. However, VBA's syntax requires you to declare the type of each variable, e.g.

Code: 
Dim MyRowCount As Long, i As Long, Last As Long, LR As Long, j As Long, AnswerP As Long, AnswerD As Long
'rather than
Dim MyRowCount, i, Last, LR, j, AnswerP, AnswerD As Long

As currently coded, all but AnswerD will be Variant (by default) which will slightly slow down the running of your code.
 
Upvote 0
Thank you both DILIPandey and StephenCrump, those are wonderful tips. Thanks for taking the time to go through my code. I will give your suggestions a try today, and will let you know if it is any faster than before. Your responses are much appreciated.

Some of the VBA StephenCrump suggested is a little out of my comfort zone/know-how, but I'll do my best to follow it and apply it.

Jackson
 
Upvote 0
you are welcome jack... let us know when you resolve the speed issue. Cheers :)


Regards,
DILIPandey
 
Upvote 0
I took your advice, and changed the formulas section to .column functions, and it is MUCH (5x) faster. I also am using .value =.value instead of copying and pasting as values. I believe the .value method is more efficient, but correct me if I'm wrong.

One more question. I've now added one additional formula line, and it takes an extremely long time to calculate and fill. I think it's because it's doing a vlookup on a range of 250,000 rows. Is there a more efficient way to perform this action? (****** beside the new line).

Thank you for all of your help,

Jackson

Code: 
[/COLOR]Sub Formulas()


Last = DataSheet.Range("A" & Rows.Count).End(xlUp).Row


    With DataSheet.Range("E2:L" & Last)
    
        .Columns(2).Formula = "=INDEX(Table2[Category],MATCH(MID(C2,4,3),Table2[Abbreviation],0))"
        .Columns(3).Formula = "=LEFT(C2,3)"
        .Columns(4).Formula = "=INDEX(Table2[Department],MATCH(MID(C2,4,3),Table2[Abbreviation],0))"
        .Columns(5).Formula = "=MID(Data!C2,7,3)"
        .Columns(6).Formula = "=""20"" & RIGHT(Data!C2,2)"
        .Columns(7).Formula = "=VLOOKUP(Data!B2,Locations,3,0)"
        .Columns(8).Formula = "=VLOOKUP(Data!B2,Locations,4,0)"
        .Value = .Value
        
        MsgBox "Preliminary Formulas Complete - Moving Onto Per Ton"
        
        .Columns(1).Formula = "=iferror(D2/VLOOKUP(LEFT(C2,3)&IF(H2=""Distribution"",""TDE"",""TIP"")&RIGHT(C2,5),$C$2:$L$236,2,0),0)"   **************
        .Value = .Value
        
    End With


End Sub
[COLOR=#333333]

 
Upvote 0
Sorry, the new code line should be this instead (250,000 rather than 236):

Code: 
.Columns(1).Formula = "=iferror(D2/VLOOKUP(LEFT(C2,3)&IF(H2=""Distribution"",""TDE"",""TIP"")&RIGHT(C2,5),$C$2:$L$250000,2,0),0)"
 
Upvote 0
Hi Jack, you can use a defined name for range c2:L250000 which will be powered with offset and counta functions.
Try searching internet for Excel: dynamic defined name and you will learn it easily. thanks.


Regards,
DILIPandey
 
Upvote 0
You also if you want to stick to using a formula need to state how your data is laid out, in particular whether column C is sorted ascending.
 
Upvote 0
Column C is not sorted in any way, it is just a list of account codes that are pulled in a different section of the VBA.

I'm looking into the dynamic named range idea right now.
 
Upvote 0
You must log in or register to reply here.

Similar threads

D
  • Question
VBA based on cell value search for it in the table and then copy a row (help with existing code)
Replies
1
Views
316
DanteAmor
DanteAmor
I
  • Question
Current Code taking 10 Hours to run. Need Help to Optimize
Replies
5
Views
239
ItalianPlatinum
I
B
  • Solved
vba code to give next Sunday date for pasted data
Replies
2
Views
176
bh24524
B
I
  • Solved
Set value for range being copied over with VBA
2
Replies
14
Views
172
ItalianPlatinum
I
P
  • Question
ListBox Click to textbox & delete row
Replies
0
Views
315
pure vito
P

Forum statistics

Threads
1,214,646
Messages
6,120,717
Members
448,985
Latest member
chocbudda

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