The macro takes too long to run

T

TamuraGui

New Member
Joined
Sep 14, 2022
Messages
4
Office Version
  1. 365
Platform
  1. Windows
I have this code, it gets the demand of a particular part no, search for a supply in another table and returns the order, date, quantity, supplier and coordinator.
I tested this on a smaller sheet and it works well, but on the sheet that I need this to run I have 30k plus lines on each table, so it takes a really long time to run,
Do you guys have a clue on how to solve this problem?
The part no´s on demand and supply are not unique, so I search for the first supply of that part no and subtract the demand from the supply amount.

VBA Code: 
Sub Plan()

    Dim rows_supply As Long
    Dim array_pnsupply() As String, array_qtysupply() As Double, array_ordersupply() As String, array_datesupply() As Date
    Dim srow As Long, drow As Long, pos As Long, dcol As Long
    Dim demand As Double, supply As Double
    
    rows_supply = WorksheetFunction.CountIf(Sheets("supply").Range("a:a"), "<>" & "") - 1
    
    ReDim array_pnsupply(rows_supply - 1)
    ReDim array_qtysupply(rows_supply - 1)
    ReDim array_ordersupply(rows_supply - 1)
    ReDim array_datesupply(rows_supply - 1)
    ReDim array_suppliersupply(rows_supply - 1)
    ReDim array_coordinatorsupply(rows_supply - 1)
    
    srow = 2
    
    Do While Sheets("Supply").Cells(srow, 1) <> ""
        array_pnsupply(srow - 2) = Sheets("Supply").Cells(srow, 10)
        srow = srow + 1
    Loop
    
    srow = 2
    
    Do While Sheets("Supply").Cells(srow, 1) <> ""
        array_qtysupply(srow - 2) = Sheets("Supply").Cells(srow, 12)
        srow = srow + 1
    Loop
    
    srow = 2
    
    Do While Sheets("Supply").Cells(srow, 1) <> ""
        array_ordersupply(srow - 2) = Sheets("Supply").Cells(srow, 1)
        srow = srow + 1
    Loop
    
    srow = 2
    
    Do While Sheets("Supply").Cells(srow, 1) <> ""
        array_datesupply(srow - 2) = Sheets("Supply").Cells(srow, 26)
        srow = srow + 1
    Loop
    
    srow = 2
    
    Do While Sheets("Supply").Cells(srow, 1) <> ""
        array_suppliersupply(srow - 2) = Sheets("Supply").Cells(srow, 5)
        srow = srow + 1
    Loop
    
    srow = 2
    
    Do While Sheets("Supply").Cells(srow, 1) <> ""
        array_coordinatorsupply(srow - 2) = Sheets("Supply").Cells(srow, 7)
        srow = srow + 1
    Loop
    
    drow = 2
    dcol = 13
    
    Do While Sheets("Demand").Cells(drow, 7) <> ""
        demand = Sheets("Demand").Cells(drow, 9).Value
        supply = 0
        pos = 0
        Do While (pos <= rows_supply - 1) And (demand > 0)
            If (Sheets("Demand").Cells(drow, 7) = array_pnsupply(pos)) And (array_qtysupply(pos) > 0) Then
                supply = array_qtysupply(pos)
                demand = demand - supply
                If demand >= 0 Then
                    Sheets("Demand").Cells(drow, dcol) = array_ordersupply(pos)
                    Sheets("Demand").Cells(drow, dcol + 1) = array_qtysupply(pos)
                    Sheets("Demand").Cells(drow, dcol + 2) = array_suppliersupply(pos)
                    Sheets("Demand").Cells(drow, dcol + 3) = array_coordinatorsupply(pos)
                    Sheets("Demand").Cells(drow, dcol + 4) = array_datesupply(pos)
                    array_qtysupply(pos) = 0
                Else
                    Sheets("Demand").Cells(drow, dcol) = array_ordersupply(pos)
                    Sheets("Demand").Cells(drow, dcol + 1) = array_qtysupply(pos) + demand
                    Sheets("Demand").Cells(drow, dcol + 2) = array_suppliersupply(pos)
                    Sheets("Demand").Cells(drow, dcol + 3) = array_coordinatorsupply(pos)
                    Sheets("Demand").Cells(drow, dcol + 4) = array_datesupply(pos)
                    array_qtysupply(pos) = -demand
                End If
                dcol = dcol + 5
            End If
            pos = pos + 1
        Loop
        drow = drow + 1
        dcol = 13
    Loop
    
    MsgBox "Finished planning, you will be redirected to the analysis!"

End Sub
 

Excel Facts

How to total the visible cells?
From the first blank cell below a filtered data set, press Alt+=. Instead of SUM, you will get SUBTOTAL(9,)
Sort by date Sort by votes
Hi.

Please make a copy of your Excel file, and test this modification on your large sheet to see if it's faster.
VBA Code: 
Sub Plan()

    Dim rows_supply As Long
    Dim array_pnsupply() As String, array_qtysupply() As Double, array_ordersupply() As String, array_datesupply() As Date
    Dim srow As Long, drow As Long, pos As Long, dcol As Long
    Dim demand As Double, supply As Double
   
    rows_supply = WorksheetFunction.CountIf(Sheets("supply").Range("a:a"), "<>" & "") - 1
   
    ReDim array_pnsupply(rows_supply - 1)
    ReDim array_qtysupply(rows_supply - 1)
    ReDim array_ordersupply(rows_supply - 1)
    ReDim array_datesupply(rows_supply - 1)
    ReDim array_suppliersupply(rows_supply - 1)
    ReDim array_coordinatorsupply(rows_supply - 1)
   
    With Sheets("Supply")
        srow = 2
        Do While .Cells(srow, 1) <> ""
            array_pnsupply(srow - 2) = .Cells(srow, 10).Value
            array_qtysupply(srow - 2) = .Cells(srow, 12).Value
            array_ordersupply(srow - 2) = .Cells(srow, 1).Value
            array_datesupply(srow - 2) = .Cells(srow, 26).Value
            array_suppliersupply(srow - 2) = .Cells(srow, 5).Value
            array_coordinatorsupply(srow - 2) = .Cells(srow, 7).Value
            srow = srow + 1
        Loop
    End With

    Application.Calculation = xlCalculationManual

    drow = 2
    dcol = 13
 
    With Sheets("Demand")
        Do While .Cells(drow, 7).Value <> ""
            demand = .Cells(drow, 9).Value
            supply = 0
            pos = 0
 
            Do While (pos <= rows_supply - 1) And (demand > 0)
                If (.Cells(drow, 7).Value = array_pnsupply(pos)) And (array_qtysupply(pos) > 0) Then
                    supply = array_qtysupply(pos)
                    demand = demand - supply
                    If demand >= 0 Then
                        .Cells(drow, dcol).Value = array_ordersupply(pos)
                        .Cells(drow, dcol + 1).Value = array_qtysupply(pos)
                        .Cells(drow, dcol + 2).Value = array_suppliersupply(pos)
                        .Cells(drow, dcol + 3).Value = array_coordinatorsupply(pos)
                        .Cells(drow, dcol + 4).Value = array_datesupply(pos)
                        array_qtysupply(pos) = 0
                    Else
                        .Cells(drow, dcol).Value = array_ordersupply(pos)
                        .Cells(drow, dcol + 1).Value = array_qtysupply(pos) + demand
                        .Cells(drow, dcol + 2).Value = array_suppliersupply(pos)
                        .Cells(drow, dcol + 3).Value = array_coordinatorsupply(pos)
                        .Cells(drow, dcol + 4).Value = array_datesupply(pos)
                        array_qtysupply(pos) = -demand
                    End If
                    dcol = dcol + 5
                End If
                pos = pos + 1
            Loop
            drow = drow + 1
            dcol = 13
        Loop

    End With

    Application.Calculation = xlCalculationAutomatic

    MsgBox "Finished planning, you will be redirected to the analysis!"

End Sub

PS.
For your MsgBox, you can have it beep and not say "Microsoft Excel" with the following modification:
VBA Code: 
MsgBox "Finished planning, you will be redirected to the analysis!", vbInformation, "Complete"
 
Upvote 0
cmowla said:
Hi.

Please make a copy of your Excel file, and test this modification on your large sheet to see if it's faster.
VBA Code: 
Sub Plan()

    Dim rows_supply As Long
    Dim array_pnsupply() As String, array_qtysupply() As Double, array_ordersupply() As String, array_datesupply() As Date
    Dim srow As Long, drow As Long, pos As Long, dcol As Long
    Dim demand As Double, supply As Double
  
    rows_supply = WorksheetFunction.CountIf(Sheets("supply").Range("a:a"), "<>" & "") - 1
  
    ReDim array_pnsupply(rows_supply - 1)
    ReDim array_qtysupply(rows_supply - 1)
    ReDim array_ordersupply(rows_supply - 1)
    ReDim array_datesupply(rows_supply - 1)
    ReDim array_suppliersupply(rows_supply - 1)
    ReDim array_coordinatorsupply(rows_supply - 1)
  
    With Sheets("Supply")
        srow = 2
        Do While .Cells(srow, 1) <> ""
            array_pnsupply(srow - 2) = .Cells(srow, 10).Value
            array_qtysupply(srow - 2) = .Cells(srow, 12).Value
            array_ordersupply(srow - 2) = .Cells(srow, 1).Value
            array_datesupply(srow - 2) = .Cells(srow, 26).Value
            array_suppliersupply(srow - 2) = .Cells(srow, 5).Value
            array_coordinatorsupply(srow - 2) = .Cells(srow, 7).Value
            srow = srow + 1
        Loop
    End With

    Application.Calculation = xlCalculationManual

    drow = 2
    dcol = 13
 
    With Sheets("Demand")
        Do While .Cells(drow, 7).Value <> ""
            demand = .Cells(drow, 9).Value
            supply = 0
            pos = 0
 
            Do While (pos <= rows_supply - 1) And (demand > 0)
                If (.Cells(drow, 7).Value = array_pnsupply(pos)) And (array_qtysupply(pos) > 0) Then
                    supply = array_qtysupply(pos)
                    demand = demand - supply
                    If demand >= 0 Then
                        .Cells(drow, dcol).Value = array_ordersupply(pos)
                        .Cells(drow, dcol + 1).Value = array_qtysupply(pos)
                        .Cells(drow, dcol + 2).Value = array_suppliersupply(pos)
                        .Cells(drow, dcol + 3).Value = array_coordinatorsupply(pos)
                        .Cells(drow, dcol + 4).Value = array_datesupply(pos)
                        array_qtysupply(pos) = 0
                    Else
                        .Cells(drow, dcol).Value = array_ordersupply(pos)
                        .Cells(drow, dcol + 1).Value = array_qtysupply(pos) + demand
                        .Cells(drow, dcol + 2).Value = array_suppliersupply(pos)
                        .Cells(drow, dcol + 3).Value = array_coordinatorsupply(pos)
                        .Cells(drow, dcol + 4).Value = array_datesupply(pos)
                        array_qtysupply(pos) = -demand
                    End If
                    dcol = dcol + 5
                End If
                pos = pos + 1
            Loop
            drow = drow + 1
            dcol = 13
        Loop

    End With

    Application.Calculation = xlCalculationAutomatic

    MsgBox "Finished planning, you will be redirected to the analysis!"

End Sub

PS.
For your MsgBox, you can have it beep and not say "Microsoft Excel" with the following modification:
VBA Code: 
MsgBox "Finished planning, you will be redirected to the analysis!", vbInformation, "Complete"
Click to expand...

Hey,

It´s faster but not that fast still,
Thanks for the tip on the MsgBox
I started learning VBA this weekend and I am from Brazil, so my code and my english might not be that good. Hahahaha
But thank you so much for your help.
 
Upvote 0
How far apart are cells that are <> "" in column A of your Supply sheet?

Also, just a tip, in case it's driving you crazy:
VBA Code: 
Do While .Cells(srow, "A") <> ""
is the same as
VBA Code: 
Do While .Cells(srow, 1) <> ""
They both have their uses, but if you are not incrementing the column number in a loop and are annoyed with having to refer to the column by a number instead of a letter, well, you can.

This is also equivalent
VBA Code: 
Do While .Range("A" & srow) <> ""

And the With that I added in your code is like factoring in math. Like how x^2+x = x(x+1).
 
Upvote 0
cmowla said:
How far apart are cells that are <> "" in column A of your Supply sheet?

Also, just a tip, in case it's driving you crazy:
VBA Code: 
Do While .Cells(srow, "A") <> ""
is the same as
VBA Code: 
Do While .Cells(srow, 1) <> ""
They both have their uses, but if you are not incrementing the column number in a loop and are annoyed with having to refer to the column by a number instead of a letter, well, you can.

This is also equivalent
VBA Code: 
Do While .Range("A" & srow) <> ""

And the With that I added in your code is like factoring in math. Like how x^2+x = x(x+1).
Click to expand...

For you to know how huge is my issue, my supply sheet has 35k lines, that´s why it´s taking too long.
And thank you so much for the tips, I didn´t know that
 
Upvote 0
What I meant was, is it continuous data, or do you have gaps of like 10 or more often?
 
Upvote 0
One of the main reasons that Vba is slow is the time taken to access the worksheet from VBa is a relatively long time.
To speed up vba the easiest way is to minimise the number of accesses to the worksheet. What is interesting is that the time taken to access a single cell on the worksheet in vba is almost identical as the time taken to access a large range if it is done in one action.

So instead of writing a loop which loops down a range copying one row at a time which will take along time if you have got 50000 rows it is much quicker to load the 50000 lines into a variant array ( one worksheet access), then copy the lines to a variant array and then write the array back to the worksheet, ( one worksheet access for each search that you are doing),

I have a simple rule for fast VBA: NEVER ACCESS THE WORKSHEET IN A LOOP.
Your code is doing multiple access tothe workhseet in a loop so it will be very slow over 30K . The way to speed this up is to use variant arrays which are usually at least 1000 times fater than the way your code is written.
I have made a very quick modification to cmowla code in post#2 which uses a variant aray for the first input. To do the output is a bit more difficult but is the way to go . With varianta aray what oyou are doing should be very very fast, (seconds)
try this:
VBA Code: 
Sub Plan()

    Dim rows_supply As Long
    Dim array_pnsupply() As String, array_qtysupply() As Double, array_ordersupply() As String, array_datesupply() As Date
    Dim srow As Long, drow As Long, pos As Long, dcol As Long
    Dim demand As Double, supply As Double
  
    rows_supply = WorksheetFunction.CountIf(Sheets("supply").Range("a:a"), "<>" & "") - 1
  
    ReDim array_pnsupply(rows_supply - 1)
    ReDim array_qtysupply(rows_supply - 1)
    ReDim array_ordersupply(rows_supply - 1)
    ReDim array_datesupply(rows_supply - 1)
    ReDim array_suppliersupply(rows_supply - 1)
    ReDim array_coordinatorsupply(rows_supply - 1)
  
    With Sheets("Supply")
     lastrow = .Cells(Rows.Count, "A").End(xlUp).Row ' dewtect the lastrow with data in it
     inarr = Range(Cells(1, 1), Cells(lastrow, 26)) 'load all the dat into a variant array
   
'        srow = 2
'        Do While .Cells(srow, 1) <> ""
         For srow = 2 To lastrow
          If inarr(srow, 1) = "" Then Exit For  ' exit loop if blank

'            array_pnsupply(srow - 2) = .Cells(srow, 10).Value
            array_pnsupply(srow - 2) = inarr(srow, 10)
            array_qtysupply(srow - 2) = inarr(srow, 12)
            array_ordersupply(srow - 2) = inarr(srow, 1)
            array_datesupply(srow - 2) = inarr(srow, 26)
            array_suppliersupply(srow - 2) = inarr(srow, 5)
            array_coordinatorsupply(srow - 2) = inarr(srow, 7)
         Next srow
  '          srow = srow + 1
  '      Loop
    End With

    Application.Calculation = xlCalculationManual

    drow = 2
    dcol = 13
 
    With Sheets("Demand")
        Do While .Cells(drow, 7).Value <> ""
            demand = .Cells(drow, 9).Value
            supply = 0
            pos = 0
 
            Do While (pos <= rows_supply - 1) And (demand > 0)
                If (.Cells(drow, 7).Value = array_pnsupply(pos)) And (array_qtysupply(pos) > 0) Then
                    supply = array_qtysupply(pos)
                    demand = demand - supply
                    If demand >= 0 Then
                        .Cells(drow, dcol).Value = array_ordersupply(pos)
                        .Cells(drow, dcol + 1).Value = array_qtysupply(pos)
                        .Cells(drow, dcol + 2).Value = array_suppliersupply(pos)
                        .Cells(drow, dcol + 3).Value = array_coordinatorsupply(pos)
                        .Cells(drow, dcol + 4).Value = array_datesupply(pos)
                        array_qtysupply(pos) = 0
                    Else
                        .Cells(drow, dcol).Value = array_ordersupply(pos)
                        .Cells(drow, dcol + 1).Value = array_qtysupply(pos) + demand
                        .Cells(drow, dcol + 2).Value = array_suppliersupply(pos)
                        .Cells(drow, dcol + 3).Value = array_coordinatorsupply(pos)
                        .Cells(drow, dcol + 4).Value = array_datesupply(pos)
                        array_qtysupply(pos) = -demand
                    End If
                    dcol = dcol + 5
                End If
                pos = pos + 1
            Loop
            drow = drow + 1
            dcol = 13
        Loop

    End With

    Application.Calculation = xlCalculationAutomatic

    MsgBox "Finished planning, you will be redirected to the analysis!"

End Sub
If I get more time I will have a look at what needs to be done for the outputs.
 
Upvote 0
I have found time to look a the rest it is a lot simpler that I thought at first glance , this soluiton is not the fastest solution because it is still makes one access to the worksheet on every iteration but it will be faster.
VBA Code: 
Sub Plan()

    Dim rows_supply As Long
    Dim array_pnsupply() As String, array_qtysupply() As Double, array_ordersupply() As String, array_datesupply() As Date
    Dim srow As Long, drow As Long, pos As Long, dcol As Long
    Dim demand As Double, supply As Double
   
    rows_supply = WorksheetFunction.CountIf(Sheets("supply").Range("a:a"), "<>" & "") - 1
   
    ReDim array_pnsupply(rows_supply - 1)
    ReDim array_qtysupply(rows_supply - 1)
    ReDim array_ordersupply(rows_supply - 1)
    ReDim array_datesupply(rows_supply - 1)
    ReDim array_suppliersupply(rows_supply - 1)
    ReDim array_coordinatorsupply(rows_supply - 1)
   
    With Sheets("Supply")
     lastrow = .Cells(Rows.Count, "A").End(xlUp).Row ' dewtect the lastrow with data in it
     inarr = Range(Cells(1, 1), Cells(lastrow, 26)) 'load all the dat into a variant array
    
'        srow = 2
'        Do While .Cells(srow, 1) <> ""
         For srow = 2 To lastrow
          If inarr(srow, 1) = "" Then Exit For
'            array_pnsupply(srow - 2) = .Cells(srow, 10).Value
            array_pnsupply(srow - 2) = inarr(srow, 10)
            array_qtysupply(srow - 2) = inarr(srow, 12)
            array_ordersupply(srow - 2) = inarr(srow, 1)
            array_datesupply(srow - 2) = inarr(srow, 26)
            array_suppliersupply(srow - 2) = inarr(srow, 5)
            array_coordinatorsupply(srow - 2) = inarr(srow, 7)
         Next srow
  '          srow = srow + 1
  '      Loop
    End With
    Dim temp(1 To 1, 1 To 5) As Variant
    Application.Calculation = xlCalculationManual

    drow = 2
    dcol = 13
 
    With Sheets("Demand")
        lastd = .Cells(Rows.Count, "G").End(xlUp).Row ' dewtect the lastrow with data in it
        darr = Range(Cells(1, 1), Cells(lastd, 9)) ' load column 1 to 9 into array
'        Do While .Cells(drow, 7).Value <> ""
        Do While darr(drow, 7) <> ""
            demand = darr(drow, 9).Value
            supply = 0
            pos = 0
 
            Do While (pos <= rows_supply - 1) And (demand > 0)
                If (darr(drow, 7) = array_pnsupply(pos)) And (array_qtysupply(pos) > 0) Then
                    supply = array_qtysupply(pos)
                    demand = demand - supply
                    If demand >= 0 Then
                        temp(1, 1) = array_ordersupply(pos)
                        temp(1, 2) = array_qtysupply(pos)
                        temp(1, 3) = array_suppliersupply(pos)
                        temp(1, 4) = array_coordinatorsupply(pos)
                        temp(1, 5) = array_datesupply(pos)
                        array_qtysupply(pos) = 0
                        Range(Cells(drow, dcol), Cells(drow, dcol + 5)) = temp
                    Else
                        temp(1, 1) = array_ordersupply(pos)
                        temp(1, 2) = array_qtysupply(pos) + demand
                        temp(1, 3) = array_suppliersupply(pos)
                        temp(1, 4) = array_coordinatorsupply(pos)
                        temp(1, 5) = array_datesupply(pos)
                        array_qtysupply(pos) = -demand
                        Range(Cells(drow, dcol), Cells(drow, dcol + 5)) = temp
                    End If
                    dcol = dcol + 5
                End If
                pos = pos + 1
            Loop
            drow = drow + 1
            dcol = 13
        Loop

    End With

    Application.Calculation = xlCalculationAutomatic

    MsgBox "Finished planning, you will be redirected to the analysis!"

End Sub
NOTE UNTEST!!!!
 
Upvote 0
You must log in or register to reply here.

Similar threads

I
  • Question Question
Listbox columns dont alter when i set the width advice please
Replies
6
Views
123
Skyybot
Skyybot
W
  • Question Question
Using goal seek within VBA
Replies
0
Views
1K
waptrick
W
E
  • Question Question
My Table created by VBA
2 3
Replies
24
Views
1K
Candyman8019
C
H
  • Question Question
Compare Demand Data to Stock Data
Replies
6
Views
562
Bosquedeguate
Bosquedeguate
M
  • Question Question
Loop through each file in folder and perform an action
Replies
0
Views
601
Monsieur Roo
M

Forum statistics

Threads
1,224,814
Messages
6,181,121
Members
453,021
Latest member
Justyna P

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