How could I improve the run speed of this code?

vbaNumpty

Board Regular
Joined
Apr 20, 2021
Messages
171
Office Version
  1. 365
Platform
  1. Windows
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!

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 Sub

The 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
 

Excel Facts

Why are there 1,048,576 rows in Excel?
The Excel team increased the size of the grid in 2007. There are 2^20 rows and 2^14 columns for a total of 17 billion cells.
What speeds up code the most is reading/ writing adjacent cells/ ranges in one go instead of cell by cell - instead of writing several lines using range.offset .... Use one line like range.resize
Bring read/write operations to the minimum.
 
Upvote 0

Forum statistics

Threads
1,213,560
Messages
6,114,309
Members
448,564
Latest member
ED38

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