The following code can take up to almost a minute to run depending on the amount of orders that are on the day. Could someone see if there are areas of opportunity to cut down the run time of the code so that it does not take on average 20-30 seconds to run?
Thanks!
The protect and uprotect calls are simple protect sheet macros, and the testDeleteCheckBoxes is as follows:
Thanks!
VBA Code:
Sub openFile()
'macro to change shipping sheet
Dim i As Integer
Dim j As Integer
Dim X As Integer
Dim y As Integer
Dim n As Integer
Dim k As Integer
Dim ordrList As Range
Dim findValue As Range
Dim addMe As Range
Dim brdRange As Range
Dim r As Range
Dim usChk As Range
Dim ordSht As Worksheet
Dim dshBoard As Worksheet
Dim myarray As Variant
Dim tDay As Date
Dim togGle As Variant
Dim toggleCheck As Variant
Dim boOl As Boolean
Dim MyLeft As Double
Dim MyTop As Double
Dim MyHeight As Double
Dim MyWidth As Double
On Error GoTo errHandler:
Dim StartTime As Double
Dim SecondsElapsed As Double
StartTime = Timer
Application.ScreenUpdating = False
Call Unprotect_DB
Call testDeleteCheckBoxes
Set ordSht = Sheet3
Set dshBoard = Sheet1
tDay = Evaluate("=today()")
dshBoard.Range("W1") = tDay
dshBoard.Range("A3:A2000").EntireRow.Clear
dshBoard.Range("A3:A2000").RowHeight = 15
ordSht.Range("S1").value = "Ship Date"
ordSht.Range("S2").value = Sheet1.Range("W1")
ordSht.Range("A2:L1048576").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _
ordSht.Range("$S$1:$S$2"), CopyToRange:=ordSht.Range("$U$1:$AF$1"), Unique:=False
ordSht.Select
With ordSht
.Range("U2:AF1048576").Sort Key1:=Range("AB2"), Order1:=xlAscending, Header:=xlGuess
End With
Sheet1.Select
Set ordrList = Sheet3.Range("outdata")
myarray = ordrList
i = Sheet3.Range("T1").value
k = 0
For j = 1 To i
Set addMe = dshBoard.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
Set findValue = ordSht.Range("A:A").Find(what:=myarray(j, 1), _
LookIn:=xlValues, lookat:=xlWhole)
X = findValue.Offset(0, 12).value
n = 0
'CUSTOMER AND ORDER/AG NUMBERS
If myarray(j, 10) = "" And myarray(j, 11) = "" Then
addMe.value = myarray(j, 3)
ElseIf myarray(j, 10) <> "" And myarray(j, 11) = "" Then
addMe.value = myarray(j, 3) & Chr(10) & " #" & myarray(j, 10)
ElseIf myarray(j, 10) = "" And myarray(j, 11) <> "" Then
addMe.value = myarray(j, 3) & Chr(10) & " AG#" & myarray(j, 11)
ElseIf myarray(j, 10) <> "" And myarray(j, 11) <> "" Then
addMe.value = myarray(j, 3) & Chr(10) & " #" & myarray(j, 10) & Chr(10) & " AG# " & myarray(j, 11)
End If
addMe.Offset(0, 16).value = Evaluate("=INDEX(CustomerTable[Salesperson],MATCH(""" & myarray(j, 3) & """,CustomerTable[Customer],0))") 'salesperson
addMe.Offset(0, 17).value = myarray(j, 9) ' delivery method
addMe.Offset(0, 18).value = myarray(j, 8) ' ship time
addMe.Offset(0, 18).NumberFormat = "h:mm AM/PM"
addMe.Offset(0, 19).value = findValue.Offset(0, 13) 'customer notes
addMe.Offset(0, 20).value = findValue.Offset(0, 12).value - 1 ' line number
addMe.Offset(0, 20).Font.ThemeColor = xlThemeColorDark1
addMe.Offset(0, 23).value = myarray(j, 1)
addMe.Offset(0, 23).Font.ThemeColor = xlThemeColorDark1
For y = 2 To X
addMe.Offset(n, 1).value = findValue.Offset(y, 0).value 'product
addMe.Offset(n, 2).value = findValue.Offset(y, 2).value 'cases
addMe.Offset(n, 3).value = findValue.Offset(y, 3).value 'pack size
addMe.Offset(n, 4).value = findValue.Offset(y, 4).value 'Staging
addMe.Offset(n, 5).value = findValue.Offset(y, 5).value 'assortment
addMe.Offset(n, 6).value = findValue.Offset(y, 6).value 'colour
addMe.Offset(n, 7).value = findValue.Offset(y, 7).value 'cover
addMe.Offset(n, 8).value = findValue.Offset(y, 8).value 'ornament
addMe.Offset(n, 9).value = findValue.Offset(y, 9).value 'upc
addMe.Offset(n, 10).value = findValue.Offset(y, 10).value 'caretag
addMe.Offset(n, 11).value = findValue.Offset(y, 11).value 'insulation
addMe.Offset(n, 12).value = findValue.Offset(y, 12).value 'sleeve
addMe.Offset(n, 13).value = findValue.Offset(y, 13).value 'notes
addMe.Offset(n, 14).value = findValue.Offset(y, 14).value 'box label
addMe.Offset(n, 21).value = k + 1
MyLeft = addMe.Offset(n, 15).Left
MyTop = addMe.Offset(n, 15).Top
MyHeight = addMe.Offset(n, 15).Height
MyWidth = addMe.Offset(n, 15).Width
If HasCheckbox(addMe.Offset(n, 15)) Then GoTo line2
ActiveSheet.CheckBoxes.Add(MyLeft, MyTop, MyWidth, MyHeight).Select
With Selection
.Caption = ""
.value = xlOff
.Locked = False
.LinkedCell = addMe.Offset(n, 22).Address
.Display3DShading = False
.Placement = xlMove
.PrintObject = True
End With
line2:
'formatting
addMe.Offset(n, 1).VerticalAlignment = xlCenter
With addMe.Offset(0, 2).Resize(X - 1, 14)
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
addMe.Offset(n, 6).WrapText = True
addMe.Offset(n, 6).Rows.AutoFit
addMe.Offset(n, 13).WrapText = True
addMe.Offset(n, 13).Rows.AutoFit
addMe.Offset(n, 21).Font.ThemeColor = xlThemeColorDark1
addMe.Offset(n, 22).Font.ThemeColor = xlThemeColorDark1
n = n + 1
k = k + 1
Next y
addMe.Offset(X - 1, 0).value = "."
addMe.Offset(X - 1, 1).value = "."
'black line
With addMe.Offset(X - 1, 0).EntireRow.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark2
.TintAndShade = -0.249977111117893
End With
With addMe.Offset(X - 1, 0).Font
.ThemeColor = xlThemeColorDark2
.TintAndShade = -0.249977111117893
End With
With addMe.Offset(X - 1, 1).Font
.ThemeColor = xlThemeColorDark2
.TintAndShade = -0.249977111117893
End With
'customer notes
addMe.Offset(0, 19).Resize(X - 1).Merge
With addMe.Offset(0, 19)
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.MergeCells = True
.WrapText = True
End With
With addMe.Offset(0, 19).Resize(X - 1).Borders
.LineStyle = xlContinuous
.Weight = xlThin
End With
'customer
Set r = Sheet5.ListObjects("UStable").Range
Set usChk = r.Find(what:=myarray(j, 3), After:=r(1))
boOl = True
addMe.Resize(X - 1).Merge
With addMe
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.MergeCells = True
.WrapText = True
End With
toggleCheck = addMe.Offset(0, 17).value
togGle = Right(addMe.Offset(0, 17).value, 6)
With addMe.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent6
.TintAndShade = 0.399975585192419
.PatternTintAndShade = 0
If usChk Is Nothing Then
GoTo line3
Else
.Color = 26367
.TintAndShade = 0
.PatternTintAndShade = 0
End If
If usChk Is Nothing Then boOl = False
line3:
If togGle = "REVIEW" And boOl = False Then
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End If
If togGle = "REVIEW" And boOl = True Then
.Pattern = xlGray8
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End If
End With
addMe.Offset(0, 16).Resize(X - 1).Merge
With addMe.Offset(0, 16)
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.MergeCells = True
.WrapText = True
End With
addMe.Offset(0, 17).Resize(X - 1).Merge
With addMe.Offset(0, 17)
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.MergeCells = True
.WrapText = True
End With
addMe.Offset(0, 18).Resize(X - 1).Merge
With addMe.Offset(0, 18)
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.MergeCells = True
.WrapText = True
End With
With addMe.Resize(X - 1, 19).Borders
.LineStyle = xlContinuous
.Weight = xlThin
End With
Next j
ActiveWorkbook.Names.Item("dashboardSumm").RefersTo = "=Dashboard!$B$3:$P$2322"
Range("dashboardSumm").FormatConditions.Add Type:=xlExpression, Formula1:="=$W3=TRUE"
Range("dashboardSumm").FormatConditions(Range("dashboardSumm").FormatConditions.Count).SetFirstPriority
With Range("dashboardSumm").FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.499984740745262
End With
Range("dashboardSumm").FormatConditions(1).StopIfTrue = False
Range("dashboardSumm").FormatConditions.Add Type:=xlExpression, Formula1:="=$N3=""DELETED"""
Range("dashboardSumm").FormatConditions(Range("dashboardSumm").FormatConditions.Count).SetFirstPriority
With Range("dashboardSumm").FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 16751052
.TintAndShade = 0
End With
Range("dashboardSumm").FormatConditions(1).StopIfTrue = False
Sheet1.Columns("W:W").Locked = False
Sheet1.Columns("W:W").FormulaHidden = False
Call Protect_DB
Range("A1").Select
'Determine how many seconds code took to run
SecondsElapsed = Round(Timer - StartTime, 2)
'Notify user in seconds
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
Exit Sub
errHandler:
Sheet1.Select
Call Protect_DB
MsgBox "No orders are in the system for the selected date.", vbOKOnly + vbInformation, "No Orders Found"
End SubThe protect and uprotect calls are simple protect sheet macros, and the testDeleteCheckBoxes is as follows:
VBA Code:
Public Sub testDeleteCheckBoxes()
'delete all CheckBoxes on Dashboard
DeleteCheckBoxes ThisWorkbook.Sheets("Dashboard").Range("P:P")
End Sub
