PDA

View Full Version : Advice required to run code faster



Poundland
04-07-2016, 04:40 AM
Hi Guys,

I have written some code below the purpose of which is to capture numbers from a separate workbook, place them into another workbook, and then capture data from this workbook, including the Date of a first occurrence, and then capture subsequent occurrences in order of appearance, the captured data to be placed into another newly created workbook.


The code all runs fine, but currently takes 7 seconds to process each number combination, with over 500 numbers to process this can take almost an hour to complete.

I am looking for some advice on how to streamline the processing.

I believe that the most time is taken by capturing the occurrence data this is done using a Select Case routine, and this is probably what is taking up the majority of the seconds, but I could be wrong.

There is a code line that Call's another routine, but this routine takes no more than a second to run.

Could you please cast your experienced eyes over my code and offer me some advice to make it run faster.

Oh, and, before somebody tells me off about it, I acknowledge that I have made a mistake by having a variable in my routine that is the same name as the routine itself... :doh:

Many Thanks in advance.


Sub Exceptions()


' Define DateVariables
Dim Dte As Range, DteDestn As Range, UserInput As Long
' Define Hierarchy Variables
Dim Msku As Range, Dept As Range, SubD As Range, Class As Range, SClass As Range, MskuDesc As Range
' Define Hierarchy Destination Variables
Dim MskuDestn As Range, DeptDestn As Range, SubDDestn As Range, ClassDestn As Range, SClassDestn As Range
Dim MskuDescDestn As Range
' Define Workbook and Worksheet Variables
Dim Wkb As Workbook, WkbNew As Workbook, Active As Workbook, ActList As Worksheet, LineF As Worksheet, NewS As Worksheet
Dim Exceptions As Range, Excep(1 To 7) As Range
Dim rngRepln As Range
' Define Mail Out Variables
Dim OutApp As Object, OutMail As Object
Chk = InputBox("Running this Macro will disable all other Excel workbooks from being accessed until it has completed. Do you want to continue (y) / (n)")
If Chk = 0 Or Chk = n Then
MsgBox ("You have chosen to not run this macro")
Exit Sub
Else
End If
' Requests user for number of weeks to investigate exceptions over
On Error Resume Next
UserInput = InputBox("Please enter the number of weeks that you want to report exceptions over? Min(1), Max (48)" _
, "Weeks Exception Selector")
On Error GoTo 0

If UserInput = 0 Then
UserInput = 55
Else
UserInput = UserInput + 6
End If
ThisWorkbook.Sheets("Lineflow").Unprotect Password:="danielle"
' Create a text box on the active worksheet.
' (Horizontal position, Vertical posiiton, Box Length, Box Height)
ActiveSheet.TextBoxes.Add(215, 150, 500, 100).Select
' Store the name of Worksheet in variable StoreWSNM.
StoreWSNM = ActiveSheet.Name
' Store the name of Text Box in variable StoreNM
StoreNM = Selection.Name
' Set the Font and Border properties of the text box.
With Selection
With Selection.Characters.Font
.Name = "Arial"
.FontStyle = "Bold"
.Size = 20
End With
With Selection.Border
.LineStyle = xlContinuous
.ColorIndex = 1
.Weight = xlThick
End With
'Set round corners for the text box.
.RoundedCorners = True
'Set message text color to black.
.Interior.ColorIndex = 15
'Assign message text to the text box.
.Characters.Text = "Please Wait... The Exception report is compiling. You will be unable to use Excel until this has finished!"
End With
' Checks if user wants to show exceptions for replen = No lines
Replen = InputBox("Do you want to compile Exceptions for Non-Replenishable Master Skus? (y)(n)")
Application.ScreenUpdating = False
' set Workbook and Worksheet objects
Set Wkb = ThisWorkbook
Set LineF = Wkb.Sheets("Lineflow")
Set WkbNew = Workbooks.Add
Set NewS = WkbNew.Sheets("Sheet1")
Set Active = Workbooks("Active Skus - Events (Hard Copy)")
Set ActList = Active.Sheets("Sheet1")
' set hierarchy destination objects
Set DeptDestn = NewS.Cells(2, 1)
Set SubDDestn = NewS.Cells(2, 2)
Set ClassDestn = NewS.Cells(2, 3)
Set SClassDestn = NewS.Cells(2, 4)
Set MskuDestn = NewS.Cells(2, 5)
Set MskuDescDestn = NewS.Cells(2, 6)
' set exception destinations objects
Set DteDestn = NewS.Cells(2, 7)
Set Excep(1) = NewS.Cells(2, 8)
Set Excep(2) = NewS.Cells(2, 9)
Set Excep(3) = NewS.Cells(2, 10)
Set Excep(4) = NewS.Cells(2, 11)
Set Excep(5) = NewS.Cells(2, 12)
Set Excep(6) = NewS.Cells(2, 13)
Set Excep(7) = NewS.Cells(2, 14)
' creates headers on new workbook
With NewS.Range("A1:M1")
.Cells(1, 1).Value = "Department"
.Cells(1, 2).Value = "Sub Department"
.Cells(1, 3).Value = "Class"
.Cells(1, 4).Value = "Sub Class"
.Cells(1, 5).Value = "Master Sku"
.Cells(1, 6).Value = "MSKU Desc"
.Cells(1, 7).Value = "First Exception Date"
.Cells(1, 8).Value = "1st Exception"
.Cells(1, 9).Value = "2nd Exception"
.Cells(1, 10).Value = "3rd Exception"
.Cells(1, 11).Value = "4th Exception"
.Cells(1, 12).Value = "5th Exception"
.Cells(1, 13).Value = "6th Exception"
.Cells(1, 14).Value = "7th Exception"
End With
LineF.Activate


Application.ScreenUpdating = False
' For Next routine to cycle through Master Skus on Active Sku List
a = 2 ' Variable used to offset row number for destinations
For Each Msku In ActList.Range(ActList.Cells(5, 3), ActList.Cells(5, 3).End(xlDown)).Cells
' Checks to see if replen option was chosen or not
' then captures the replen option on the Active Sku list
' based on value the master sku exceptions are compiled or not
If Replen = "n" Then
Set rngRepln = Msku.Cells.Offset(0, 6)
Else
GoTo cc
End If
If rngRepln.Value = "No" Then GoTo bb
cc:
' If the MSKU value is in error then move to next MSKU
If Msku.Value = "#N/A" Then GoTo dd Else
Application.ScreenUpdating = False
LineF.Cells(5, 6) = Msku.Value ' PLaces Master Sku into Lineflow
Application.ScreenUpdating = False
Set Dept = LineF.Cells(5, 9) ' Captures Hierarchy data from Lineflow update
Set SubD = LineF.Cells(5, 11)
Set Class = LineF.Cells(5, 13)
Set SClass = LineF.Cells(5, 15)
Set MskuDesc = LineF.Cells(5, 7)
' Archives data into Database
Call archive
Col = 6
' clears exception variables
Excep(1) = ""
Excep(2) = ""
Excep(3) = ""
Excep(4) = ""
Excep(5) = ""
Excep(6) = ""
Excep(7) = ""
' Loops through exception range until valid value is found for each exception
Do
Col = Col + 1
For Rw = 83 To 89
Set Exceptions = LineF.Cells(Rw, Col)
If Exceptions.Value <> "" Then
Select Case Excep(1).Value <> "" ' Case routine cycles through each exception and assigns where is nothing
Case False
Excep(1) = Exceptions.Value
Set Dte = LineF.Cells(7, Exceptions.Column) ' captures first exception date
DeptDestn = Dept.Value
SubDDestn = SubD.Value
ClassDestn = Class.Value
SClassDestn = SClass.Value
MskuDestn = Msku.Value
MskuDescDestn = MskuDesc.Value
DteDestn = Dte.Value
a = a + 1 ' Changes the row variable for the destinations
GoTo bb
Case True
End Select
Select Case Excep(2).Value <> ""
Case False
If Excep(1).Value = Exceptions.Value Then
GoTo bb
Else
End If
Excep(2) = Exceptions.Value
GoTo bb
Case True
End Select
Select Case Excep(3).Value <> ""
Case False
If Excep(1).Value = Exceptions.Value Or Excep(2).Value = Exceptions.Value Then
GoTo bb
Else
End If
Excep(3) = Exceptions.Value
GoTo bb
Case True
End Select
Select Case Excep(4).Value <> ""
Case False
If Excep(1).Value = Exceptions.Value Or Excep(2).Value = Exceptions.Value _
Or Excep(3).Value = Exceptions.Value Then
GoTo bb
Else
End If
Excep(4) = Exceptions.Value
GoTo bb
Case True
End Select
Select Case Excep(5).Value <> ""
Case False
If Excep(1).Value = Exceptions.Value Or Excep(2).Value = Exceptions.Value _
Or Excep(3).Value = Exceptions.Value Or Excep(4).Value = Exceptions.Value Then
GoTo bb
Else
End If
Excep(5) = Exceptions.Value
GoTo bb
Case True
End Select
Select Case Excep(6).Value <> ""
Case False
If Excep(1).Value = Exceptions.Value Or Excep(2).Value = Exceptions.Value _
Or Excep(3).Value = Exceptions.Value Or Excep(4).Value = Exceptions.Value _
Or Excep(5).Value = Exceptions.Value Then
GoTo bb
Else
End If
Excep(6) = Exceptions.Value
GoTo bb
Case True
End Select
Select Case Excep(7).Value <> ""
Case False
If Excep(1).Value = Exceptions.Value Or Excep(2).Value = Exceptions.Value _
Or Excep(3).Value = Exceptions.Value Or Excep(4).Value = Exceptions.Value _
Or Excep(5).Value = Exceptions.Value Or Excep(6).Value = Exceptions.Value Then
GoTo bb
Else
End If
Excep(7) = Exceptions.Value
GoTo bb
Case True
End Select
Else
End If
bb:
Next Rw
' Loops until the user defined weeks have been reached or until the Last Exception place has beem filled.
Loop Until Col = UserInput Or Excep(7).Value <> ""
' re-sets the destination Variables
' set hierarchy destination objects
Set DeptDestn = NewS.Cells(a, 1)
Set SubDDestn = NewS.Cells(a, 2)
Set ClassDestn = NewS.Cells(a, 3)
Set SClassDestn = NewS.Cells(a, 4)
Set MskuDestn = NewS.Cells(a, 5)
Set MskuDescDestn = NewS.Cells(a, 6)
' set exception destinations objects
Set DteDestn = NewS.Cells(a, 7)
Set Excep(1) = NewS.Cells(a, 8)
Set Excep(2) = NewS.Cells(a, 9)
Set Excep(3) = NewS.Cells(a, 10)
Set Excep(4) = NewS.Cells(a, 11)
Set Excep(5) = NewS.Cells(a, 12)
Set Excep(6) = NewS.Cells(a, 13)
Set Excep(7) = NewS.Cells(a, 14)
dd:
Next Msku
NewS.Activate
With NewS.Range("A1:M1")
.AutoFilter
End With
With NewS.UsedRange
.Columns.AutoFit
End With
Application.DisplayAlerts = False
WkbNew.SaveAs ("I:\H911 Events and Supply Chain\Lineflow\Events Exceptions\Events Exceptions " & Format(Now, "yyyy.mm.dd") & " .xlsx")
WkbNew.Close False
Application.DisplayAlerts = True
LineF.Activate
LineF.Cells(5, 6) = "" ' Clears Master Sku into Lineflow
Sheets("Lineflow").Unprotect Password:="danielle"
' Attempt to close the message box down
' Makes sure the proper Worksheet is selected.
Worksheets(StoreWSNM).Select
' Makes sure the proper text box is selected.
ActiveSheet.TextBoxes(StoreNM).Select
' Deletes the Please Wait... text box.
'ThisWorkbook.Sheets("Lineflow").Unprotect Password:="Danielle"
Selection.Delete
Application.ScreenUpdating = True
ThisWorkbook.Sheets("Lineflow").Protect Password:="danielle"
MsgBox ("The Exception Report will now be emailed to all parties")
End sub

snb
04-07-2016, 05:42 AM
Why did you assume posting a sample workbook wasn't required ?

Poundland
04-07-2016, 06:05 AM
There are three different workbooks that are required to run the code if you include the sub routine in the middle, all of which are far too large to attach, the main workbook where the calculations take place cannot be reduced in size as there are many calculations across the tabs that make up the data that is collected as the exceptions.

I was kind of hoping that there would be something in my code that was so obvious as to why it was running as it does, if there is not then apologies.

Poundland
04-07-2016, 07:00 AM
I have adapted my code with some code sent to me by SamT on another thread in this forum, and this code works, the only issue I have is that it captures the same exception more than once, where I only want to capture the first instance of it and ignore all other instances of the same exception if they exist.

If you have any ideas on how I can achieve this please let me know.

Below is the original code section that only captures each exception once along with the new code section that works faster but captures the same exception more than once.

Original Code

' Loops through exception range until valid value is found for each exception
Do
Col = Col + 1
For Rw = 83 To 89
Set Exceptions = LineF.Cells(Rw, Col)
If Exceptions.Value <> "" Then
Select Case Excep(1).Value <> "" ' Case routine cycles through each exception and assigns where is nothing
Case False
Excep(1) = Exceptions.Value
Set Dte = LineF.Cells(7, Exceptions.Column) ' captures first exception date
DeptDestn = Dept.Value
SubDDestn = SubD.Value
ClassDestn = Class.Value
SClassDestn = SClass.Value
MskuDestn = Msku.Value
MskuDescDestn = MskuDesc.Value
DteDestn = Dte.Value
a = a + 1 ' Changes the row variable for the destinations
GoTo bb
Case True
End Select
Select Case Excep(2).Value <> ""
Case False
If Excep(1).Value = Exceptions.Value Then
GoTo bb
Else
End If
Excep(2) = Exceptions.Value
GoTo bb
Case True
End Select
Select Case Excep(3).Value <> ""
Case False
If Excep(1).Value = Exceptions.Value Or Excep(2).Value = Exceptions.Value Then
GoTo bb
Else
End If
Excep(3) = Exceptions.Value
GoTo bb
Case True
End Select
Select Case Excep(4).Value <> ""
Case False
If Excep(1).Value = Exceptions.Value Or Excep(2).Value = Exceptions.Value _
Or Excep(3).Value = Exceptions.Value Then
GoTo bb
Else
End If
Excep(4) = Exceptions.Value
GoTo bb
Case True
End Select
Select Case Excep(5).Value <> ""
Case False
If Excep(1).Value = Exceptions.Value Or Excep(2).Value = Exceptions.Value _
Or Excep(3).Value = Exceptions.Value Or Excep(4).Value = Exceptions.Value Then
GoTo bb
Else
End If
Excep(5) = Exceptions.Value
GoTo bb
Case True
End Select
Select Case Excep(6).Value <> ""
Case False
If Excep(1).Value = Exceptions.Value Or Excep(2).Value = Exceptions.Value _
Or Excep(3).Value = Exceptions.Value Or Excep(4).Value = Exceptions.Value _
Or Excep(5).Value = Exceptions.Value Then
GoTo bb
Else
End If
Excep(6) = Exceptions.Value
GoTo bb
Case True
End Select
Select Case Excep(7).Value <> ""
Case False
If Excep(1).Value = Exceptions.Value Or Excep(2).Value = Exceptions.Value _
Or Excep(3).Value = Exceptions.Value Or Excep(4).Value = Exceptions.Value _
Or Excep(5).Value = Exceptions.Value Or Excep(6).Value = Exceptions.Value Then
GoTo bb
Else
End If
Excep(7) = Exceptions.Value
GoTo bb
Case True
End Select
Else
End If
bb:
Next Rw
' Loops until the user defined weeks have been reached or until the Last Exception place has beem filled.
Loop Until Col = UserInput Or Excep(7).Value <> ""


New Code

' NEW ROUTINE
' *****BELOW ROUTINE WORKS BUT IT CAPTURES THE SAME EXCEPTIONS MORE THAN ONCE
' *****I ONLY WANT TO CAPTURE EACH EXCEPTION WHERE IT EXISTS FOR EACH SKU NUMBER ONLY ONCE

Dim iExcep As Long, iTest As Long

Do
Col = Col + 1
For Rw = 83 To 89
If LineF.Cells(Rw, Col) <> "" Then
'For routine cycles through each exception and assigns where is nothing
For iExcep = 1 To 7
If Excep(iExcep) = "" Then
For iTest = 1 To iExcep - 1 'Won't test if iExcep = 1
If Excep(iExcep) = Excep(iTest) Or Excep(iExcep) = LineF.Cells(Rw, Col) Then GoTo bb
Next iTest
Excep(iExcep) = LineF.Cells(Rw, Col)
If iExcep = 1 And rngDte = "" Then
Set Dte = LineF.Cells(7, Col) ' captures first exception date
DeptDestn = Dept.Value
SubDDestn = SubD.Value
ClassDestn = Class.Value
SClassDestn = SClass.Value
MskuDestn = Msku.Value
MskuDescDestn = MskuDesc.Value
DteDestn = Dte.Value
'a is not Declared
a = a + 1 ' Changes the row variable for the destinations
End If
GoTo bb
End If
Next iExcep
End If
bb:
Next Rw

Loop Until Col = UserInput Or Excep(7).Value <> ""