Macro runs slowly

C

Cakz Primz

Board Regular
Joined
Dec 4, 2016
Messages
102
Office Version
  1. 365
Platform
  1. Windows
Dear all,

I need your help and kind assistance.

I have a workbook in .xlsb extension, 6MB size with only 1 sheet, no linking to another workbook. And I have not open another workbook.
The original data is csv, with Purchase Order number in text format, so I need to change into number format.
The number of rows is 85,000 and the columns used until AE (31 columns, starting from column A).

It takes more than 3 minutes just to run the code below:

VBA Code: 
Sub Banyak()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Dim ws As Worksheet
    Set ws = ActiveSheet
    
    Dim lRow As Long
    lRow = Cells(Rows.Count, 1).End(xlUp).Row
    With ws
    
    .Range("B2:B" & lRow).FormulaR1C1 = "=XLOOKUP(RC1,DataSource!C32,DataSource!C[31])"
    .Range("C2:C" & lRow).FormulaR1C1 = "=XLOOKUP(RC1,DataSource!C32,DataSource!C[33])"
    .Range("D2:D" & lRow).FormulaR1C1 = "=RC[-1]/RC[-2]"
    .Range("E2:E" & lRow).FormulaR1C1 = "=RC[-3]-RC[-2]"
    .Range("F2:F" & lRow).FormulaR1C1 = "=XLOOKUP(RC1,DataSource!C32,DataSource!C[1])"
    .Range("G2:G" & lRow).FormulaR1C1 = "=XLOOKUP(RC1,DataSource!C32,DataSource!C[4])"
    .Range("H2:H" & lRow).FormulaR1C1 = "=XLOOKUP(RC1,DataSource!C32,DataSource!C[15])"
    .Range("I2:I" & lRow).FormulaR1C1 = "=XLOOKUP(RC1,DataSource!C32,DataSource!C[16])"
    .Range("J2:J" & lRow).FormulaR1C1 = "=XLOOKUP(RC1,DataSource!C32,DataSource!C[6])"
    .Range("K2:K" & lRow).FormulaR1C1 = "=XLOOKUP(RC1,DataSource!C32,DataSource!C[6])"
    .Range("L2:L" & lRow).FormulaR1C1 = "=XLOOKUP(RC1,DataSource!C32,DataSource!C[19])"
    .Range("M2:M" & lRow).FormulaR1C1 = "=IF(RC[-1]<RC[-3],""Ahead"",IF(RC[-1]=RC[-3],""On schedule"",""Late""))"
    .Range("B2:M" & lRow).Value = .Range("B2:M" & lRow).Value
    End With
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic



Is there something wrong with the code? or perhaps there is another better solution to accelerate?

Thank you
prima - Indonesia
 
Sort by date Sort by votes
Cakz Primz said:
Dear kevin9999,

Thanks so much for your kind assistance and help.
Let me try the code, and I will inform you, tomorrow.

Again, thanks for everything.

Regards,
Prima - Indonesia
Click to expand...
Thank you for letting me know 👍
 
Upvote 0

Excel Facts

Remove leading & trailing spaces
Save as CSV to remove all leading and trailing spaces. It is faster than using TRIM().
Dea
Alex Blakenburg said:
I am not entirely happy with mine either but here is another version.

VBA Code: 
Sub Summarize_v02()

    Dim t As Double: t = Timer
   
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Dim ws As Worksheet
    Dim LRow As Long
    Dim dictPO_SumRow As Object, dictPOKey As String
    Dim dictStatus_Col As Object, dictStatusKey As String
    Dim rngSrc As Range, rngOut As Range, cellHdg As Range
    Dim arrSrc As Variant, arrSum() As Variant, arrOut() As Variant
    Dim iSrc As Long, iSum As Long, iSumNew As Long, iHdg, SumColID As Long, j As Long
       
    Set ws = ActiveSheet
    With ws
        LRow = .Cells(Rows.Count, 1).End(xlUp).Row
        Set rngSrc = .Range("A4:AO" & LRow)                         '<-- Modify as required
        arrSrc = rngSrc.Value
        Set rngOut = .Range("AF4:AO" & LRow)                        '<-- Modify as required - repeated PO No and Count Columns
        ReDim arrSum(1 To UBound(arrSrc), 1 To rngOut.Columns.Count)
        ReDim arrOut(1 To UBound(arrSrc), 1 To rngOut.Columns.Count)
    End With
   
    ' Load Dictionary for Headings / Categories relative position
    Set dictStatus_Col = CreateObject("Scripting.dictionary")
    For Each cellHdg In rngOut.Offset(-1).Cells
        dictStatusKey = UCase(cellHdg.Value)
        If Not dictStatus_Col.exists(dictStatusKey) Then
            iHdg = iHdg + 1
            If cellHdg.Value = "" Then dictStatusKey = "PO NO"          ' Not used just a place holder
            dictStatus_Col(dictStatusKey) = iHdg
        End If
    Next cellHdg
   
   
    ' Load Dictionary Unique PO nos and total count by Category
    Set dictPO_SumRow = CreateObject("Scripting.dictionary")
    For iSrc = 1 To UBound(arrSrc)
        dictPOKey = CStr(arrSrc(iSrc, 5))
        If Not dictPO_SumRow.exists(dictPOKey) Then
            iSumNew = iSumNew + 1
            dictPO_SumRow(dictPOKey) = iSumNew
        End If
        iSum = dictPO_SumRow(dictPOKey)
        arrSum(iSum, 1) = arrSrc(iSrc, 5)
        arrSum(iSum, 2) = arrSum(iSum, 2) + 1
       
        dictStatusKey = UCase(arrSrc(iSrc, 22))
        SumColID = dictStatus_Col(dictStatusKey)
        arrSum(iSum, SumColID) = arrSum(iSum, SumColID) + 1
    Next iSrc
   
    ' Load output array based on all rows in source and outputting count values against repeating PO numbers
    For iSrc = 1 To UBound(arrSrc)
        arrOut(iSrc, 1) = arrSrc(iSrc, 5)
        dictPOKey = CStr(arrSrc(iSrc, 5))
        For j = 2 To UBound(arrSum, 2)
            arrOut(iSrc, j) = arrSum(dictPO_SumRow(dictPOKey), j)
        Next j
    Next iSrc
  
    rngOut.Resize(UBound(arrOut)) = arrOut

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
   
    MsgBox "Completed " & UBound(arrSrc) & " rows in " & Timer - t & "seconds."
End Sub
Click to expand...
Dear Alex Blakenburg,

Thank you so much for helping me out.
I will try the code, and I will inform you, tomorrow.

Thanks for everything.

Regards,
Prima - Indonesia
 
Upvote 0
kvsrinivasamurthy said:
To convert text format to number format.
Select the range
Data->> Text to columns
Delimited->>Next->>Next
Select Date ->> Finish
Click to expand...
Dear kvsrinivasamurthy,

Thank you for attention, but the problem is why the macro is taking to long to run.
I've got 2 codes from kevin9999 and Alex Blakenburg, that I need to try.
I believe both the codes are working well.

Regards,
Prima - Indonesia
 
Upvote 0
kevin9999 said:
I'm not entirely happy with it, but the following code (based on your XL2BB sample extended down) takes around 10 seconds for 85K+ rows. Let me know how you go with it.

VBA Code: 
Option Explicit
Dim LRow As Long
Dim ws As Worksheet
Sub Cakz_Primz()
    Dim t As Double: t = Timer
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlManual
    End With
   
    Set ws = Worksheets("DataSource")   '<< Check sheet name
    LRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
   
    '1. Get values into column AF
    With ws
        .Range("E4:E" & LRow).Copy
        .Range("AF4").PasteSpecial xlPasteValues
        Application.CutCopyMode = False
    End With
   
    '2. Get values into column AG
    CountIfAF
   
    '3 Get values into AH:AO
    CountIfAH
   
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlAutomatic
    End With
   
    MsgBox "Completed " & LRow - 3 & " rows in " & Timer - t & "seconds."
End Sub

Sub CountIfAF()
    Dim R As Long, s As String, Data As Variant, Result As Variant
    Data = Range("E4:E" & LRow)
    ReDim Result(1 To UBound(Data), 1 To 1)
   
    With CreateObject("Scripting.Dictionary")
      For R = 1 To UBound(Data)
        s = CStr(Data(R, 1))
        .Item(s) = .Item(s) + 1
      Next
    For R = 1 To UBound(Data)
        Result(R, 1) = .Item(CStr(Data(R, 1)))
      Next
    End With
    Range("AG4").Resize(UBound(Result)) = Result
End Sub

Sub CountIfAH()
    Dim R As Long, s As String, Data, Result
    Dim ar1, i As Long, x As String
    Data = ws.Range("E4:V" & LRow)
    ReDim Result(1 To UBound(Data), 1 To 1)
   
    With CreateObject("Scripting.Dictionary")
        For i = 34 To 41
            x = ws.Cells(3, i)
            For R = 1 To UBound(Data)
              If UCase(Data(R, 18)) = UCase(x) Then
                s = CStr(Data(R, 1))
                .Item(s) = .Item(s) + 1
              End If
            Next
            For R = 1 To UBound(Data)
                Result(R, 1) = .Item(CStr(Data(R, 1)))
            Next
            Cells(4, i).Resize(UBound(Result)) = Result
            .RemoveAll
        Next i
    End With
End Sub
Click to expand...
Dear kevin9999,

Glad to inform you that your magic spell is working like a charm. It takes only less than 3 seconds to summarize it.
You are a magician. An angel that send to help us.
I am speechless.
Problem solved !

Thanks for everything, thank so much.
I am really appreciate it.

Dear MrExcel,
Thank you very, very, very much.

Best regards,
Prima - Indonesia
 
Upvote 0
Cakz Primz said:
Dear kevin9999,

Glad to inform you that your magic spell is working like a charm. It takes only less than 3 seconds to summarize it.
You are a magician. An angel that send to help us.
I am speechless.
Problem solved !

Thanks for everything, thank so much.
I am really appreciate it.

Dear MrExcel,
Thank you very, very, very much.

Best regards,
Prima - Indonesia
Click to expand...
Yes, it's interesting that the first time I tested it, it took around 10 seconds - but when I tested it several more times it ran in under 3 seconds! Anyway, glad we were all able to help (y) :)
 
Upvote 0
Alex Blakenburg said:
I am not entirely happy with mine either but here is another version.

VBA Code: 
Sub Summarize_v02()

    Dim t As Double: t = Timer
   
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Dim ws As Worksheet
    Dim LRow As Long
    Dim dictPO_SumRow As Object, dictPOKey As String
    Dim dictStatus_Col As Object, dictStatusKey As String
    Dim rngSrc As Range, rngOut As Range, cellHdg As Range
    Dim arrSrc As Variant, arrSum() As Variant, arrOut() As Variant
    Dim iSrc As Long, iSum As Long, iSumNew As Long, iHdg, SumColID As Long, j As Long
       
    Set ws = ActiveSheet
    With ws
        LRow = .Cells(Rows.Count, 1).End(xlUp).Row
        Set rngSrc = .Range("A4:AO" & LRow)                         '<-- Modify as required
        arrSrc = rngSrc.Value
        Set rngOut = .Range("AF4:AO" & LRow)                        '<-- Modify as required - repeated PO No and Count Columns
        ReDim arrSum(1 To UBound(arrSrc), 1 To rngOut.Columns.Count)
        ReDim arrOut(1 To UBound(arrSrc), 1 To rngOut.Columns.Count)
    End With
   
    ' Load Dictionary for Headings / Categories relative position
    Set dictStatus_Col = CreateObject("Scripting.dictionary")
    For Each cellHdg In rngOut.Offset(-1).Cells
        dictStatusKey = UCase(cellHdg.Value)
        If Not dictStatus_Col.exists(dictStatusKey) Then
            iHdg = iHdg + 1
            If cellHdg.Value = "" Then dictStatusKey = "PO NO"          ' Not used just a place holder
            dictStatus_Col(dictStatusKey) = iHdg
        End If
    Next cellHdg
   
   
    ' Load Dictionary Unique PO nos and total count by Category
    Set dictPO_SumRow = CreateObject("Scripting.dictionary")
    For iSrc = 1 To UBound(arrSrc)
        dictPOKey = CStr(arrSrc(iSrc, 5))
        If Not dictPO_SumRow.exists(dictPOKey) Then
            iSumNew = iSumNew + 1
            dictPO_SumRow(dictPOKey) = iSumNew
        End If
        iSum = dictPO_SumRow(dictPOKey)
        arrSum(iSum, 1) = arrSrc(iSrc, 5)
        arrSum(iSum, 2) = arrSum(iSum, 2) + 1
       
        dictStatusKey = UCase(arrSrc(iSrc, 22))
        SumColID = dictStatus_Col(dictStatusKey)
        arrSum(iSum, SumColID) = arrSum(iSum, SumColID) + 1
    Next iSrc
   
    ' Load output array based on all rows in source and outputting count values against repeating PO numbers
    For iSrc = 1 To UBound(arrSrc)
        arrOut(iSrc, 1) = arrSrc(iSrc, 5)
        dictPOKey = CStr(arrSrc(iSrc, 5))
        For j = 2 To UBound(arrSum, 2)
            arrOut(iSrc, j) = arrSum(dictPO_SumRow(dictPOKey), j)
        Next j
    Next iSrc
  
    rngOut.Resize(UBound(arrOut)) = arrOut

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
   
    MsgBox "Completed " & UBound(arrSrc) & " rows in " & Timer - t & "seconds."
End Sub
Click to expand...
Dear Alex Blakenburg,

Glad to inform you that your magic spell is working like a charm. It takes only less than 6 seconds to summarize it.
You are a magician. An angel that send to help us.
Problem solved !

Both you and kevin9999 and other angels in this forum are a great man.

Thanks for everything Sir, thank so much.
I am really appreciate it.

Dear MrExcel,
Thank you very, very, very much.


Best regards,
Prima - Indonesia
 
Upvote 0
You must log in or register to reply here.

Similar threads

C
  • Question Question
Need help: VBA is too slow to write 6 formulas
2
Replies
16
Views
1K
snjpverma
S
M
  • Question Question
VBA Subtotal 47,000+ Rows
Replies
1
Views
259
igold
igold
W
  • Solved
Looking For Tips To Improve My VBA
Replies
8
Views
231
who am i
W
W
  • Solved
Add a column w/ formula to copy / paste macro
Replies
5
Views
306
wknight7
W
G
  • Solved
Autofill to bottom of worksheet (macro not working)
Replies
1
Views
599
Artik
Artik

Forum statistics

Threads
1,224,823
Messages
6,181,185
Members
453,020
Latest member
Mohamed Magdi Tawfiq Emam

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