perfomance VBA with loop

[arnauddes]

Hello,

I have to run vba code with several loop.VBA work but very bad performance.

Anyone has some tips to reduce execution time of my vba code?

Sub macro()
'

' Declare variables'
    Dim i As Integer
    Dim j As Integer
    Dim k As Integer
    Dim wk_orderlines As Integer
    Dim wk_tot_volume As Integer
    Dim wk_proportion As String
    Dim wk_LEG_store As String
    Dim wk_comp_promo As String
    Dim wk_sap_art As String
    Dim wk_art_store As String
    Dim wk_store_quantity As Double
    Dim wk_store_quantity2 As Double
    Dim wk_to_be_forecasted As String
    Dim wk_delivery As Integer
    Dim wk_colisage As Integer
    Dim wk_average As Integer
    
'Clean SAS UP_LOAD Sheet
    Application.ScreenUpdating = False
    Sheets("LIST_TOV4").Select
    Range("A2").Select
    Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
    Selection.Clear
    Range("A2").Select


' Start program
    i = 1
    k = 1
    Sheets("LIST_TO").Select
    Range("A2").Select
    Do Until IsEmpty(ActiveCell)
        Sheets("LIST_TO").Select
        i = i + 1
        wk_to_be_forecasted = ActiveSheet.Cells(i, 11).Value
        If wk_to_be_forecasted = "Y" Then
            wk_orderlines = ActiveSheet.Cells(i, 1).Value
            wk_tot_volume = ActiveSheet.Cells(i, 12).Value
            wk_comp_promo = ActiveSheet.Cells(i, 13).Value
            wk_sap_art = ActiveSheet.Cells(i, 14).Value
            wk_delivery = ActiveSheet.Cells(i, 10).Value
            wk_average = ActiveSheet.Cells(i, 16).Value
            wk_colisage = ActiveSheet.Cells(i, 9).Value
                
' Catch Stores
            j = 1
            Sheets("LIST_TOV2").Select
            Range("A2").Select
        
            Do Until IsEmpty(ActiveCell)
                j = j + 1
                wk_proportion = "0.008"
                wk_store_sales = ""
                wk_store_quantity = 0
            
                
                Sheets("LIST_TOV2").Select
                wk_LEG_store = ActiveSheet.Cells(j, 1).Value
                wk_art_store = wk_sap_art & "/" & wk_comp_promo & "/" & wk_LEG_store
            
                If wk_comp_promo = "non comp promo" Then
                    On Error Resume Next
                    wk_proportion = Application.WorksheetFunction.VLookup(Cells(j, 1), Sheets("PROPORTIONS").Range("A1:C200").Value, 3, False)
                    wk_store_quantity = wk_tot_volume * wk_proportion
                    wk_store_quantity2 = Application.WorksheetFunction.RoundUp(wk_store_quantity, 0)
                    On Error GoTo 0
                    
                    
                Else
                    On Error Resume Next
                    wk_store_sales = Application.WorksheetFunction.VLookup(wk_art_store, Sheets("LIST_TOV4").Range("B1:I100000").Value, 8, False)
                    wk_colisage = Application.WorksheetFunction.VLookup(wk_art_store, Sheets("LIST_TOV4").Range("B1:G100000").Value, 6, False)
                    wk_store_quantity = (wk_store_sales / wk_delivery) / wk_colisage
                    wk_store_quantity2 = Application.WorksheetFunction.RoundUp(wk_store_quantity, 0)
                    On Error GoTo 0
                End If
            
' Fill the upload sheet
                k = k + 1
                Sheets("LIST_TOV4").Select
                Cells(k, 1).Value = wk_LEG_store + 10000
                Cells(k, 2).Value = wk_orderlines
                Cells(k, 3).Value = wk_store_quantity2
                Sheets("LIST_TOV2").Select
                ActiveCell.Offset(1, 0).Select
            Loop
        Else
        End If
        
        Sheets("LIST_TO").Select
        ActiveCell.Offset(1, 0).Select
    Loop

' Position cursor on top of all sheets
    Sheets("LIST_TO").Select
    Range("A1").Select
    Sheets("PROPORTIONS").Select
    Range("A1").Select
    Sheets("LIST_TOV4").Select
    Range("A1").Select
    Sheets("LIST_TOV2").Select
    Range("A1").Select
    Sheets("LIST_TOV4").Select
    Range("A1").Select
    Application.ScreenUpdating = True
    MsgBox "Macro successfully ended"
    


End Sub

tx,

Kr,

Arnd

[Paul_Hossler]

1. I added CODE tags to format your macro -- you can use the [#] icon to insert them next time


2. take a look at the FAQ -- link in my signature

3. Use Long, not Integer

4. Don't need to .Select something to act on it

5. Use Application.ScreenUpdating = False at the start

6. Someone will suggest using Arrays, but that can be for later

[offthelip]

Your code has been written using multiple accesses to the worksheet, I am not in the slightest bit surprised that it takes a long time:
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.

the way you have sent up your loops of looping until the active cell is empty isn't going to work well with variant arrays and is a very inefficient way of doing loops

Also it is completely unnecesary and usually makes for slow code to be continually selecting different sheets and cells.

Also it is much faster to use a variant arrays instead of Vlookup which accesses the worksheet .
So the good news is you can very easily speed up this code enormously, however to do a proper job of it you are going to need to completely rewrite it.
To my mind there is hardly a line of code which couldn't be improved on.

to put it simply,
1: get rid of all the selects , (use with worksheets instead)
2: load all the worksheets entirely in variant arrays using lastrow and lastcolumn to determine the size of the variant arrays
3: change the loop control for using

 ActiveCell.Offset(1, 0).Select

to a do loop from 1 to lastrow
4: define an output variant array, write the data into this array during the loop and then output the whole array at the end of the loop
I hope this helps.