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

Spell Check in Excel
Press F7 to start spell check in Excel. Be careful, by default, Excel does not check Capitalized Werds (whoops)
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
1Sorted
2Axyz
3Babc
4Cghi
5Eqwe
6Gasd
7Hzxc
8
9Lookup
10Cghi
11DCan't find

<colgroup><col style="width: 25pxpx"><col><col></colgroup><thead>
</thead><tbody>
</tbody>
1​
 
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
322
DanteAmor
DanteAmor
I
  • Question
Current Code taking 10 Hours to run. Need Help to Optimize
Replies
5
Views
253
ItalianPlatinum
I
B
  • Solved
vba code to give next Sunday date for pasted data
Replies
2
Views
182
bh24524
B
I
  • Solved
Set value for range being copied over with VBA
2
Replies
14
Views
183
ItalianPlatinum
I
P
  • Question
ListBox Click to textbox & delete row
Replies
0
Views
325
pure vito
P

Forum statistics

Threads
1,214,849
Messages
6,121,922
Members
449,056
Latest member
denissimo

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