arnauddes
06-21-2018, 07:29 AM
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
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