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
 
Sort by date Sort by votes
Hi there, can you explain to me why this would be faster than simply having a static range like $C$2:$L$250000? Wouldn't a dynamic range only help with determining the exact amount of rows there are, so it would only save a little bit of time? Eg. dynamic may find 237,000 rows while static would have 250,000, so it would only save 13,000 rows worth of where its looking?
 
Upvote 0

Excel Facts

When did Power Query debut in Excel?
Although it was an add-in in Excel 2010 & Excel 2013, Power Query became a part of Excel in 2016, in Data, Get & Transform Data.
jacksongf said:
Hi there, can you explain to me why this would be faster than simply having a static range like $C$2:$L$250000? Wouldn't a dynamic range only help with determining the exact amount of rows there are, so it would only save a little bit of time? Eg. dynamic may find 237,000 rows while static would have 250,000, so it would only save 13,000 rows worth of where its looking?
Click to expand...

Yes, if that were the case, you're not going to save a huge amount of processing time.

But you should be able to save heaps of time by sorting your VLookup table (as Mark858 mentioned). You're looking for an exact match, which means the search is linear and Excel might need to go through the entire table looking for a match (or not).

If you sort the table, you can use a much faster binary search method. Here's one way you could do this:

B10: =IFERROR(IF(VLOOKUP(A10,A$2:A$7,TRUE)=A10,VLOOKUP(A10,A$2:B$7,2,TRUE),"Can't find"),"Can't find")

Excel 2010
AB
Sorted
Axyz
Babc
Cghi
Eqwe
Gasd
Hzxc
Lookup
Cghi
DCan't find

<colgroup><col style="width: 25pxpx"><col><col></colgroup><thead>
</thead><tbody>
[TD="align: center"]1[/TD]

[TD="align: right"][/TD]

[TD="align: center"]2[/TD]

[TD="align: center"]3[/TD]

[TD="align: center"]4[/TD]

[TD="align: center"]5[/TD]

[TD="align: center"]6[/TD]

[TD="align: center"]7[/TD]

[TD="align: center"]8[/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]

[TD="align: center"]9[/TD]

[TD="align: right"][/TD]

[TD="align: center"]10[/TD]

[TD="align: center"]11[/TD]

</tbody>
1​
 
Upvote 0
You must log in or register to reply here.

Similar threads

H
  • Solved
Macro to speedy up process when copying Data
Replies
3
Views
60
Logit
Logit
D
  • Question Question
VBA based on cell value search for it in the table and then copy a row (help with existing code)
Replies
1
Views
524
DanteAmor
DanteAmor
J
  • Question Question
Speeding up VBA
Replies
7
Views
54
jvoss
J
I
  • Solved
Current Code taking 10 Hours to run. Need Help to Optimize
Replies
5
Views
502
ItalianPlatinum
I
C
  • Question Question
How to automatically paste the data from one sheet to another using VBA
Replies
4
Views
187
Alex Blakenburg
A

Forum statistics

Threads
1,223,240
Messages
6,170,951
Members
452,368
Latest member
jayp2104

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