Increasing speed of Excel VBA code used for order report

Question

I'm on my second revision of this workbook and I've brought the run-time down from 37 seconds to 9 seconds on my computer and from 30-40 minutes to 8 minutes on my boss's old laptop.

I'd like to know if there is anything I can do to further increase the speed of this code that I may have missed. I took 3-4 subs and moved them all into one so the formatting is a bit off in the main but I've brought all the variables to the top. All sub/functions called by the main are included, I believe I have them reasonably optimized but I included them just to be complete.

Purpose of code

• create sheets based on codes entered by the user,
• narrow down a data report using those codes,
• break out the data to individual sheets identified by the code,
• extract data from the previous report that has a match to a line in the latest report,
• move the data on each sheet into date blocks including holdays that are defined on starting sheet (Past Due, Due Today, Due in next X days, Due after next x days, Quotes),
• delete the worksheets containing the old data,
• and apply row highlight conditional formatting.

Here is the main code:

Option Explicit
Sub FormatAllData()
Dim SheetName As String, Path As String, FileDate As String, ServerAddress As String, shtName As String, sServer As String, fServer As String, sIniPath As String, SFullPathFileName As String, strDirectory As String, _
 GoodFolder As String, ShtName2 As String
Dim SheetRng As Range, RowDelete As Range, cell As Range, SearchRange As Range, PastDueRange As Range, DueTodayRange As Range, DueNextRange As Range, DueAfterRange As Range, QuoteRange As Range, HolidayRange As Range
Dim DaysAhead As Variant, oSuccess As Variant, varDirectory As Variant, Originator As Variant, CurrentSheet As Variant, StartingRow As Variant, EndingRow As Variant, EndingCell As Variant
Dim All_VBA As Worksheet, All_Data As Worksheet, StartSht As Worksheet, TemplateWS As Worksheet, NewWS As Worksheet, ws As Worksheet, workingSheet As Worksheet
Dim LastRow As Long, i As Long, PastDue As Long, FormRow As Long, SheetPasteRow As Long
Dim objFSO As Object, objFolder As Object, objSubFolder As Object
 
Dim Today As Date, nextWD As Date, cellLK As Date
Dim Template As Integer, NumMonth As Integer
 
Dim flag As Boolean, AlertsValue As Boolean
Dim wb1 As Workbook, wb2 As Workbook
Set objFSO = CreateObject("Scripting.FileSystemObject")
'-----Sheet Variables-----
Set StartSht = Sheet1
Set All_VBA = Sheet2
Set All_Data = Sheet4
SheetPasteRow = 17 'What row we paste data at on copied templates
'-------------------------
If All_Data.Range("A1") = "" Then Call Running_Data.AutofillAll
All_VBA.Visible = xlSheetVisible
All_VBA.UsedRange.Delete 'Clear sheet for new data
All_Data.UsedRange.Rows(2).Resize(All_Data.UsedRange.Rows.Count - 1, All_Data.UsedRange.Columns.Count).Copy 'Copy only used ranged from data sheet excluding header row
All_VBA.Range("A1").PasteSpecial xlPasteAll 'Paste starting in A1
Set SheetRng = All_VBA.UsedRange.Columns(1) 'Sets range to only column A and all used rows
For Each cell In SheetRng.Cells 'Loop through each cell in SheetRNG
 If cell.Value = "" Then 'Check if cell value is blank
 With All_VBA
 .Cells(cell.Row - 1, "P") = .Cells(cell.Row, "P") 'Copy text up if row is blank so SO text matches SO order
 If Not RowDelete Is Nothing Then 'This range is used to store rows we need to delete, we can not union the range if range is blank
 Set RowDelete = Union(RowDelete, cell) 'Add current range to RowDelete, will be used to delete rows later
 Else
 Set RowDelete = cell 'Set RowDelete to current range, will be used to delete rows later
 End If
 End With
 End If
Next cell
If Not RowDelete Is Nothing Then 'Check for blank range so we don't error on delete
 RowDelete.EntireRow.Delete 'Delete all rows in RowDelete range
End If
Set RowDelete = Nothing 'Set to nothing so we can use it again
Call Common_Functions.SheetArrayBuild 'Build sheet array to use when reducing lines and build Strg
For Each cell In SheetRng.Cells
 If Not InStr(1, Strg, Delim & cell.Value & Delim, vbTextCompare) > 0 Then
 If Not RowDelete Is Nothing Then 'This range is used to store rows we need to delete, we can not union the range if range is blank
 Set RowDelete = Union(RowDelete, cell) 'Add current range to RowDelete, will be used to delete rows later
 Else
 Set RowDelete = cell 'Set RowDelete to current range, will be used to delete rows later
 End If
 End If
Next cell
 
If Not RowDelete Is Nothing Then 'Check for blank range so we don't error on delete
 RowDelete.EntireRow.Delete 'Delete all rows in RowDelete range
End If
With All_VBA
 LastRow = .UsedRange.Rows.Count 'Find LastRow using UsedRange of dataset
 Application.CutCopyMode = False 'Make sure clipboard is clean for cut/copy/paste operations
 .Range("H1:I" & LastRow).Cut 'Cut Quantity Ordered and Quantity Set Aside so we can move off main area
 .Range("O1:O" & LastRow).Insert Shift:=xlToRight 'Insert cut columns so they are not in main viewing area
 .Range("M1:P" & LastRow).Insert Shift:=xlToRight 'Insert 4 extra columns, will later hold the workcenter and description for order and pull
 .Range("I1:I" & LastRow).NumberFormat = "0" 'Format to number format, no decimals
 
 'Range(.Range("M1"), .Cells(LastRow, "M")).Formula = "=ExtractDigitsFunction($T1,7)" 'Pull latest WO number from text attachment using ExtractDigits function
 'Range(.Range("M1"), .Cells(LastRow, "M")).Value = Range(.Range("M1"), .Cells(LastRow, "M")).Value 'Replace formula range with values
 Call Extract_Digits_Function.ExtractDigitsRegex(LastRow, All_VBA) 'Alternative to using the function, same speed but easier to understand and modify
 
 Range(.Range("U1"), .Cells(LastRow, "U")).Formula = "=IF(J1=K1,1,0)" 'Helper formula to find Order Date = Promised Delivery and push to end of Commodity Code sort
 Range(.Range("U1"), .Cells(LastRow, "U")).Value = Range(.Range("U1"), .Cells(LastRow, "U")).Value 'Replace helper formula range with values
 .Range("A1:U" & LastRow).Sort key1:=.Range("A1"), order1:=xlAscending, key2:=.Range("U1"), order2:=xlAscending, key3:=.Range("K1"), order3:=xlAscending, Header:=xlNo 'Sort by Commodity Code, then by Helper Column, then my Promised Delivery date
 .Range("C1:C" & LastRow & ",T1:U" & LastRow).Delete xlShiftToLeft 'Delete columns Or Ty, Text Attachment and date helper
 .Range("A1:R" & LastRow).HorizontalAlignment = xlCenter 'Center format everything, we will be copying this data so it must be formatted
 .Range("A1:R" & LastRow).EntireColumn.AutoFit 'Autofit all used columns, we will be copying this data so it must be formatted
End With
Call Common_Functions.DeleteWS 'Delete all extra worksheets before we build new
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Create new worksheets from array and template
Set TemplateWS = Sheet6
TemplateWS.Visible = xlSheetVisible
i = 0
SheetName = ""
DaysAhead = 0
For i = LBound(SheetArray) To UBound(SheetArray)
 SheetName = SheetArray(i, 1)
 DaysAhead = SheetArray(i, 2)
 If Not Common_Functions.SheetExists(SheetName) Then
 TemplateWS.Copy After:=Sheets(Worksheets.Count)
 Set NewWS = Sheets(Worksheets.Count)
 NewWS.Name = SheetName
 NewWS.Range("D4").Value = "Past Due " & Chr("24")
 NewWS.Range("D7").Value = "Due Today " & Chr("24")
 NewWS.Range("D10").Value = "=IF(" & DaysAhead & "=1,CONCATENATE(""Due in the next working day " & Chr("24") & """),CONCATENATE(""Due in the next ""," & DaysAhead & ","" working days " & Chr("24") & """))"
 NewWS.Range("D13").Value = "=IF(" & DaysAhead & "=1,CONCATENATE(""Due after the next working day " & Chr("24") & """),CONCATENATE(""Due after the next ""," & DaysAhead & ","" working days " & Chr("24") & """))"
 NewWS.Range("D16").Value = "Quotes " & Chr("24")
 NewWS.Range("D4:D16").Value = NewWS.Range("D4:D16").Value
 End If
Next i
TemplateWS.Visible = xlSheetVeryHidden
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'// Store the current directory for later restoration.
sIniPath = CurDir
sServer = StartSht.Range("K12").Value 'Get the server address for dialog box
If Right(sServer, 1) <> "\" Then sServer = sServer & "\" 'Add backslash if missing
If SetCurrentDirectoryA(sServer) <> 0 Then 'Make sure directory exists
 Set objFolder = objFSO.GetFolder(sServer)
 NumMonth = 0
 q = 0
 NumMonth = Month(Date)
 fServer = ""
 
 Do While q < 12
 
 For Each objSubFolder In objFolder.subfolders
 If InStr(1, UCase(objSubFolder.Name), UCase(MonthName(NumMonth, True)), vbTextCompare) > 1 Then GoodFolder = objSubFolder.Name: Exit For
 Next objSubFolder
 
 If GoodFolder = "" Then Exit Do
 
 strDirectory = sServer & GoodFolder & "\"
 flag = True
 varDirectory = Dir(strDirectory, vbNormal)
 
 Do While flag = True
 If varDirectory = "" Then 'If no files exist, back month up and try again
 NumMonth = NumMonth - 1
 q = q + 1
 Exit Do
 Else 'If file exists then set fServer and exit the loop
 fServer = sServer & GoodFolder & "\"
 flag = False
 Exit Do
 End If
 Loop
 If Not flag Then Exit Do 'Used to exit main loop
 Loop
End If
'// Check if successfully connected, else try to connect to fallback locations
If SetCurrentDirectoryA(fServer) = 0 Then 'Fallback to Standards if we started with bad server
 MsgBox "Unable to connect to: " & fServer & vbNewLine & vbNewLine & "Will attempt to use fallback location after hitting ""OK""", vbInformation
 fServer = "\\Standards\" 'Fallback location used in case user location fails
 oSuccess = SetCurrentDirectoryA(fServer) 'Sets current directory and checks if successful
End If
If SetCurrentDirectoryA(fServer) = 0 Then 'Fall back to user documents if Standards fails
 MsgBox "Failed to connect to fallback location: " & fServer & vbNewLine & vbNewLine & "Opening to default location...", vbInformation ': Exit Sub
 fServer = "C:\Users\" & Environ("username") & "\Documents"
 oSuccess = SetCurrentDirectoryA(fServer) 'Sets current directory and checks if successful
End If
If SetCurrentDirectoryA(fServer) = 0 Then 'Failed to connect to all, quit macro
 MsgBox "Failed to connect to all available locations, quitting now." & vbNewLine & vbNewLine & "Error 22: Please contact Tyler to have error fixed.", vbCritical: End
End If
'////
'// Show the GetOpenFilename dialog.
SFullPathFileName = Application.GetOpenFilename("All Excel Files (*.xls*)," & _
 "*.xls*", 1, "Select Excel File", "Open", False)
If SFullPathFileName <> "False" Then 'If filename isn't blank then we open the workbook
 Set wb1 = Workbooks.Open(SFullPathFileName)
 Set wb2 = ThisWorkbook
 
 i = 0
 For i = LBound(SheetArray) To UBound(SheetArray) 'Loops through array, copies available data from last report
 shtName = SheetArray(i, 1)
 If Common_Functions.SheetExists(shtName, wb1) Then 'Make sure sheet exists in old workbook
 Set copysheet = wb1.Worksheets(shtName)
 If Not Common_Functions.SheetExists(shtName & "_Old") Then
 wb2.Sheets.Add(After:=wb2.Sheets(shtName)).Name = shtName & "_Old"
 Set workingSheet = wb2.Sheets(shtName & "_Old")
 copysheet.UsedRange.Copy 'Copy just the used range
 wb2.Sheets(shtName & "_Old").Range("A1").PasteSpecial xlPasteValues
 If wb2.Sheets(shtName & "_Old").Range("C1").Value = "Or Ty" Then wb2.Sheets(shtName & "_Old").Columns("C").Delete 'Used to allow copying of data from old workbook, we removed Or Ty from the new one
 End If
 Application.CutCopyMode = False 'Clear clipboard
 copysheet.UsedRange.Delete 'Delete all data from copy sheet, allows us to close workbook faster
 End If
 Next i
 wb1.Close False 'Close copy workbook
 StartSht.Activate 'Make sure we reactivate starting sheet
ElseIf SFullPathFileName = "False" Then
 Template = MsgBox("Is this the first time running the report with these codes?" & vbNewLine & vbNewLine & "Press Yes to continue or No to stop.", vbYesNo, "Template")
 If Template = 7 Then Call Common_Functions.DeleteWS: StartSht.Activate: End 'If we want to end, delete created worksheets, activate startsheet and stop macro execution
End If
'// Lastly.... restore to the users initial directory.
SetCurrentDirectoryA sIniPath
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
i = Empty
LastRow = Empty
LastRow = All_VBA.UsedRange.Rows.Count + 1
For i = LBound(SheetArray()) To UBound(SheetArray())
 
 CurrentSheet = SheetArray(i, 1)
 
 With Sheets(CurrentSheet)
 
 If .Columns("A").Find(what:="5", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlRows, SearchDirection:=xlPrevious).Row <> 16 Then GoTo NextI 'Skip to next iteration, used to prevent running code on sheet that was already done (in case of duplicates on start sheet)
 
 EndingRow = Empty
 StartingRow = Empty
 Set EndingCell = All_VBA.Range("A1:A" & LastRow).Find(what:=CurrentSheet, After:=All_VBA.Range("A" & LastRow), SearchDirection:=xlPrevious) 'Test if value exists
 If Not EndingCell Is Nothing Then 'If value is not nothing, set EndingRow to found row and then find starting row
 EndingRow = EndingCell.Row 'Capture row
 StartingRow = All_VBA.Range("A1:A" & LastRow).Find(what:=CurrentSheet, After:=All_VBA.Range("A" & EndingRow), SearchDirection:=xlNext).Row 'No need to test, if EndingCell exists then we can always find StartingRow
 End If
 
 If EndingRow <> Empty And StartingRow <> Empty Then 'If both are empty then skip this code as we have nothing to do
 All_VBA.Range(All_VBA.Cells(StartingRow, "A"), All_VBA.Cells(EndingRow, "R")).Copy .Cells(SheetPasteRow, "A")
 Today = Date
 DaysAhead = SheetArray(i, 2)
 nextWD = Application.WorksheetFunction.WorkDay(Date, DaysAhead, StartSht.Range("E2:E23"))
 LastRow2 = .Cells(.Rows.Count, "B").End(xlUp).Row
 
 Set SearchRange = Range(.Cells(SheetPasteRow, "A"), .Cells(LastRow2, "R"))
 
 If Common_Functions.SheetExists(CurrentSheet & "_Old") Then
 
 lastrow3 = Sheets(CurrentSheet & "_Old").Cells(Sheets(CurrentSheet & "_Old").Rows.Count, "B").End(xlUp).Row
 
 For Each cell In SearchRange.Columns("L").Cells
 FormRow = cell.Row
 
 If .Cells(cell.Row, "L").Value = "" Then
 .Cells(cell.Row, "L").FormulaArray = "=IFERROR(INDEX(" & CurrentSheet & "_Old!L1:L" & lastrow3 & ",MATCH(B" & FormRow & "&C" & FormRow & "," & CurrentSheet & "_Old!B1:B" & lastrow3 & "&" & CurrentSheet & "_Old!C1:C" & lastrow3 & ",0))&"""","""")"
 .Cells(cell.Row, "L").Value = .Cells(cell.Row, "L").Value
 End If
 
 If .Cells(cell.Row, "N").Value = "" Then
 .Cells(cell.Row, "N").FormulaArray = "=IFERROR(INDEX(" & CurrentSheet & "_Old!N1:N" & lastrow3 & ",MATCH(B" & FormRow & "&C" & FormRow & "," & CurrentSheet & "_Old!B1:B" & lastrow3 & "&" & CurrentSheet & "_Old!C1:C" & lastrow3 & ",0))&"""","""")"
 .Cells(cell.Row, "N").Value = .Cells(cell.Row, "N").Value
 End If
 
 .Cells(cell.Row, "T").FormulaArray = "=IFERROR(INDEX(" & CurrentSheet & "_Old!T1:T" & lastrow3 & ",MATCH(B" & FormRow & "&C" & FormRow & "," & CurrentSheet & "_Old!B1:B" & lastrow3 & "&" & CurrentSheet & "_Old!C1:C" & lastrow3 & ",0))&"""","""")"
 .Cells(cell.Row, "T").Value = .Cells(cell.Row, "T").Value
 .Cells(cell.Row, "V").FormulaArray = "=IFERROR(INDEX(" & CurrentSheet & "_Old!S1:S" & lastrow3 & ",MATCH(B" & FormRow & "&C" & FormRow & "," & CurrentSheet & "_Old!B1:B" & lastrow3 & "&" & CurrentSheet & "_Old!C1:C" & lastrow3 & ",0))&"""","""")"
 .Cells(cell.Row, "V").Value = .Cells(cell.Row, "V").Value
 .Cells(cell.Row, "W").FormulaArray = "=IFERROR(INDEX(" & CurrentSheet & "_Old!U1:U" & lastrow3 & ",MATCH(B" & FormRow & "&C" & FormRow & "," & CurrentSheet & "_Old!B1:B" & lastrow3 & "&" & CurrentSheet & "_Old!C1:C" & lastrow3 & ",0))&"""","""")"
 .Cells(cell.Row, "W").Value = .Cells(cell.Row, "W").Value
 .Hyperlinks.Add Anchor:=.Cells(cell.Row, "R"), Address:="", SubAddress:=CurrentSheet & "!R" & cell.Row, TextToDisplay:=.Cells(cell.Row, "R").Value
 Next
 
 End If
 For Each cell In SearchRange.Columns(10).Cells
 promisedate = .Cells(cell.Row, "J").Value
 orderdate = .Cells(cell.Row, "I").Value
 
 If promisedate < Today And orderdate <> promisedate Then
 If Not PastDueRange Is Nothing Then Set PastDueRange = Union(PastDueRange, cell) Else Set PastDueRange = cell
 ElseIf promisedate = Today And orderdate <> promisedate Then
 If Not DueTodayRange Is Nothing Then Set DueTodayRange = Union(DueTodayRange, cell) Else Set DueTodayRange = cell
 ElseIf promisedate > Today And promisedate <= nextWD And orderdate <> promisedate Then
 If Not DueNextRange Is Nothing Then Set DueNextRange = Union(DueNextRange, cell) Else Set DueNextRange = cell
 ElseIf promisedate > nextWD And orderdate <> promisedate Then
 If Not DueAfterRange Is Nothing Then Set DueAfterRange = Union(DueAfterRange, cell) Else Set DueAfterRange = cell
 ElseIf orderdate = promisedate Then
 If Not QuoteRange Is Nothing Then Set QuoteRange = Union(QuoteRange, cell) Else Set QuoteRange = cell
 End If
 Next
 
 If Not PastDueRange Is Nothing Then
 PastDueRange.EntireRow.Cut
 .Range("A3").Insert xlShiftDown
 Set PastDueRange = Nothing
 End If
 
 If Not DueTodayRange Is Nothing Then
 pasterow = .Columns("A").Find(what:="1", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlRows, SearchDirection:=xlPrevious).Row + 2
 DueTodayRange.EntireRow.Cut
 .Range("A" & pasterow).Insert xlShiftDown
 Set DueTodayRange = Nothing
 End If
 
 If Not DueNextRange Is Nothing Then
 pasterow = .Columns("A").Find(what:="2", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlRows, SearchDirection:=xlPrevious).Row + 2
 DueNextRange.EntireRow.Cut
 .Range("A" & pasterow).Insert xlShiftDown
 Set DueNextRange = Nothing
 End If
 
 If Not DueAfterRange Is Nothing Then
 pasterow = .Columns("A").Find(what:="3", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlRows, SearchDirection:=xlPrevious).Row + 2
 DueAfterRange.EntireRow.Cut
 .Range("A" & pasterow).Insert xlShiftDown
 Set DueAfterRange = Nothing
 End If
 
 If Not QuoteRange Is Nothing Then
 pasterow = .Columns("A").Find(what:="4", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlRows, SearchDirection:=xlPrevious).Row + 2
 QuoteRange.EntireRow.Cut
 .Range("A" & pasterow).Insert xlShiftDown
 Set QuoteRange = Nothing
 End If
 
 .UsedRange.HorizontalAlignment = xlCenter
 .UsedRange.EntireColumn.AutoFit
 
 End If
NextI:
 End With
 
Next i
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
 
AlertsValue = Application.DisplayAlerts
Application.DisplayAlerts = False
For Each ws In ThisWorkbook.Worksheets 'Delete all worksheets with "_Old" in name
 If InStr(1, ws.Name, "_OLD", vbTextCompare) > 0 Then ws.Delete
Next ws
Application.DisplayAlerts = AlertsValue
 
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Call RowColumnHighlight.Highlight
All_VBA.Visible = xlSheetVeryHidden
End Sub

Running_Data.AutofillAll:

Option Explicit 'Done
Sub AutofillAll()
 
 Dim wb2 As Workbook, All_Data As Worksheet, searchstring As Variant, Location As Variant, File As Variant, fd As FileDialog, Answer As Integer, FileName As Variant, FileDate As Date, FileTime As Variant, _
 wb1 As Workbook, copysheet As Worksheet
 
 Set wb2 = ThisWorkbook
 Set All_Data = Sheet4
 searchstring = "All"
 Location = Sheet1.Range("K7").Value
 File = UCase(Dir(Location & "*" & searchstring & "*")) 'Returns only files that include search string, possibly faster
 
 If File = "" Then 'Test if file found, else bring up message box and allow selection
 MsgBox """All"" data file could not be found, please use dialog to verify" & vbNewLine & "modified date and select file.", vbInformation, "All data file not found"
 Set fd = Application.FileDialog(msoFileDialogFilePicker)
 With fd
 .InitialView = msoFileDialogViewList
 .Filters.Clear
 .Filters.Add "Excel", "*.xls*"
 .Filters.Add "Excel", "*.csv"
 .FilterIndex = 1
 .AllowMultiSelect = False
 .InitialFileName = Location
 .Title = "Select All data file"
 Answer = .Show
 If Not Answer = 0 Then FileName = .SelectedItems(1) Else End 'Answer 0 = cancelled file dialog, exit code
 End With
 Else
 FileName = Location & File
 End If
 FileDate = DateValue(FileDateTime(FileName))
 FileTime = TimeValue(FileDateTime(FileName))
 If FileDate = Date Then
 Set wb1 = Workbooks.Open(FileName)
 Set copysheet = wb1.Worksheets(1)
 Application.CutCopyMode = False
 copysheet.UsedRange.Copy
 All_Data.Range("A1").PasteSpecial xlPasteAll
 Application.CutCopyMode = False
 copysheet.UsedRange.Delete
 wb1.Close
 Else
 MsgBox "File date is not current, please download new data.", vbInformation, "File Date"
 End
 End If
 Sheet1.Activate
 Sheet1.Range("D2").Value = FileDate
 Sheet1.Range("D3").Value = FileTime
End Sub

Common_Functions.SheetArrayBuild:

Option Explicit
Public SheetArray() As Variant
Public Strg As String
Public Const Delim As String = "%"
Sub SheetArrayBuild()
Dim arraylength As Long, currentrow As Long, q As Long, CurrentB As Variant, TempArray() As Variant, i As Long
 arraylength = WorksheetFunction.CountA(Sheet1.Range("A2:A100")) 'Find number of entries for array
 
 If arraylength <= 0 Then MsgBox "Missing commodity codes": End 'Quit everything if we have no commodity codes, everything must have commodity code 'Exit sub if we have no commodity codes
 
ReDim SheetArray(1 To arraylength, 1 To 2)
 
 currentrow = 2
 For q = LBound(SheetArray) To UBound(SheetArray) 'Loop count is size of array
 If Sheet1.Cells(currentrow, "A").Value = "" Then 'Checks if cell is blank, if blank it decrements array position
 q = q - 1 'Reduce q as we didn't find anything, this bypasses using GOTO statement
 Else
 SheetArray(q, 1) = UCase(Sheet1.Cells(currentrow, "A").Value) 'Sets array position "q" value equal to value in column "A", row "currentrow"
 CurrentB = Sheet1.Cells(currentrow, "B").Value 'Grabs value of (B, CurrentRow) and stores for use
 If CurrentB = "" Or CurrentB <= 0 Or Not IsNumeric(CurrentB) Then 'Checks for blank, less than or equal to 0, or for something not a number
 SheetArray(q, 2) = Sheet1.Range("D1").Value 'Default Days Ahead value
 Else 'Must be a number greater than 0
 SheetArray(q, 2) = CurrentB 'Set to cell value
 End If
 End If
 currentrow = currentrow + 1
 Next q
 ReDim TempArray(LBound(SheetArray) To UBound(SheetArray))
 For i = LBound(SheetArray) To UBound(SheetArray)
 TempArray(i) = SheetArray(i, 1)
 Next i
 
 Strg = Join(TempArray(), Delim)
 Strg = Delim & Strg & Delim 'Must include delimiter before and after and search cell value including delim before and after (;SWC;) or we get partial matches, ex. "WC"
 Erase TempArray
End Sub

Extract_Digits_Function.ExtractDigitsRegex:

Sub ExtractDigitsRegex(LastRow As Variant, WkSht As Worksheet) 'Regex sub
 Dim regEx As New RegExp
 Dim strPattern As String
 Dim strInput As String
 Dim strReplace As String
 Dim Myrange As Range
 Set Myrange = WkSht.Range("T1:T" & LastRow)
 For Each c In Myrange
 strPattern = "(?:^|\D)([1-2]{1}\d{6})(?!\d)"
 strInput = c.Value
 With regEx
 .Global = True
 .MultiLine = True
 .IgnoreCase = False
 .Pattern = strPattern
 End With
 
 Dim matches As Object, Match As Object
 If regEx.test(strInput) Then
 Set matches = regEx.Execute(strInput)
 
 For Each Match In matches
 If Match.SubMatches(0) > current Then
 current = Match.SubMatches(0)
 ElseIf current = "" Then
 current = Match.SubMatches(0)
 End If
 Next
 WkSht.Cells(c.Row, "M").Value = current
 End If
 current = ""
 Next
End Sub

Common_Functions.DeleteWS:

Sub DeleteWS()
Dim ws As Worksheet, AlertsValue As Boolean
'-----Startup Code--------
With Application
 AlertsValue = .DisplayAlerts 'Store this value so we don't override a calling sub
 .DisplayAlerts = False 'Make sure this is off or we get a dialog box
End With
'------------------------
For Each ws In Worksheets 'Safe sheet list, must be updated or sheet will be deleted
 If ws.Name <> Sheet1.Name And ws.Name <> Sheet2.Name And ws.Name <> Sheet3.Name And ws.Name <> Sheet4.Name And ws.Name <> Sheet5.Name And ws.Name <> Sheet6.Name Then
 ws.UsedRange.Delete
 ws.Delete
 End If
Next
Sheet1.Range("G2:G100").ClearContents 'Clear past due
 
'-----Finish Code--------
With Application
 .DisplayAlerts = AlertsValue 'Return value to original status
End With
'------------------------
End Sub

RowColumnHighlight.Highlight:

Option Explicit 'Done
Sub Highlight()
Dim HighlightRow As Long, CurrentSheet As String, i As Long, HighlightStatus As Long
Call Common_Functions.SheetArrayBuild
If Sheet1.Range("P1").Value = True Then
 HighlightStatus = 0
Else
 HighlightStatus = 1
End If
For i = LBound(SheetArray()) To UBound(SheetArray())
 CurrentSheet = SheetArray(i, 1)
 With Sheets(CurrentSheet)
 .Range("Z1").Value = HighlightStatus
 .Cells.FormatConditions.Delete
 HighlightRow = .UsedRange.Rows.Count
 With Range(.Cells(1, "A"), .Cells(HighlightRow, "W"))
 
 .FormatConditions.Add Type:=xlExpression, Formula1:="=ROW(A1)=$Y1ドル"
 .FormatConditions(.FormatConditions.Count).SetFirstPriority
 
 With .FormatConditions(1).Font
 .Bold = True
 .Italic = False
 .TintAndShade = 0
 End With
 
 With .FormatConditions(1).Interior
 .PatternColorIndex = xlAutomatic
 .Color = Sheet1.Range("N1").Interior.Color
 End With
 
 .FormatConditions(1).StopIfTrue = False
 
 .FormatConditions.Add Type:=xlExpression, Formula1:="=OR($Y1ドル=1,$B1="""", $Z1ドル=1)"
 .FormatConditions(.FormatConditions.Count).SetFirstPriority
 .FormatConditions(1).StopIfTrue = True
 End With
 End With
Next i
End Sub

Common_Functions.SheetExists:

Public Function SheetExists(shtName As String, Optional wb As Workbook) As Boolean
 'This is used, do not delete
 Dim sht As Worksheet
 If wb Is Nothing Then Set wb = ThisWorkbook
 On Error Resume Next
 Set sht = wb.Sheets(shtName)
 On Error GoTo 0
 SheetExists = Not sht Is Nothing
 End Function

• user34073: Are you using rubberduck yet?
• tjb1: @Hosch250, didn't even know that existed. I'll have to see if I can get it put on my computer!
• Mathieu Guindon: Please edit the title to better tell us /summarize roughly what the purpose of the code is. Everyone wants faster code ;-)
• tjb1: @Mat'sMug, I added some to the title and more in the body. Do you need more?

Answer 1

Variables

You have a bunch of variables that aren't defined, here, in this version of the code you posted:

copysheet
lastrow2
lastrow3
promisedate
orderdate
paserow
c
current

When you don't define your variable, VBA will declare it as a Variant, which are objects:

Performance. A variable you declare with the Object type is flexible enough to contain a reference to any object. However, when you invoke a method or property on such a variable, you always incur late binding (at run time). To force early binding (at compile time) and better performance, declare the variable with a specific class name, or cast it to the specific data type.

By not declaring variables, you could possibly be paying a penalty.

You also have some hungarian naming going on - objFSO, strDirectory.

No need to tell me what type it is, it should have a name that tell me that instead.

strDirectory - pathTo or directoryPath

---

Prefer ByVal over ByRef

When you pass arguments they are inherently passed ByRef. You need to explicitly pass them ByVal or if they should be by ref, explicitly say that as well

Sub ExtractDigitsRegex(LastRow As Variant, WkSht As Worksheet)
Public Function SheetExists(shtName As String, Optional wb As Workbook)
'SetCurrentDirectoryA cannot be found
Public Function SheetExists(shtName As String, Optional wb As Workbook)

RubberDuckVBA says:

Parameters [...] passed by reference [...] can be confusing and bug-prone. Prefer passing parameters by value.

Vbnullstring

All of your empty strings "" can be converted to Vbnullstring - a built-in constant.

---

Implicity

Every time you use Range, Sheets, or Worksheets, you are implicitly referring to ActiveSheet. Try to be explicit in those.

The following functions have a better alternative

chr - chr$
right - right$
ucase - ucase$
curdir - curdir$
environ - environ$

These can all be represented by strings only, so force it to be string.

Variables

Declaring a bunch of variables in the same line isn't really the way to go with VBA, but you've done good work ensuring all of them have been Typed individually.

Every Call you make, doesn't need the Call - it's obsolete. e.g.

Call ExtractDigitsRegex(LastRow, All_VBA) 'can be -
ExtractDigitsRegex lastRow, All_VBA

---

Comments

You have a lot of comments in this code. Comments - "code tell you how, comments tell you why". The code should speak for itself, if it needs a comment, it might need to be made more clear. If not, the comment should describe why you're doing something rather than how you're doing it. Here are a few reasons to avoid comments all together.

---

Performance

Your big concern is performance. The main bottleneck you're running into is using the sheet to do anything. It's like using .Select - Be sure to avoid things like .Select - it just slows the code down by needing to fiddle with the spreadsheet while doing everything else behind the scenes. There's a good question on StackOverflow addressing this.

E.g.

Sheet1.Activate
Sheet1.Range("D2").Value = FileDate
Sheet1.Range("D3").Value = FileTime

You can completely avoid the entire .Activate and this will work fine.

You use an array here -

ReDim SheetArray(1 To arraylength, 1 To 2)

Which is perfect. But there are other places where you prefer to work on the sheet rather than in an array

If .Cells(cell.Row, "L").Value = "" Then
.Cells(cell.Row, "L").FormulaArray = "=IFERROR(INDEX(" & CurrentSheet & > 
"_Old!L1:L" & lastrow3 & ",MATCH(B" & FormRow & "&C" &
FormRow & "," & CurrentSheet & "_Old!B1:B" & lastrow3 & "&" &
CurrentSheet & "_Old!C1:C" & lastrow3 & ",0))&"""","""")"
 .Cells(cell.Row, "L").Value = .Cells(cell.Row, "L").Value
 End If

That's quite a formula to execute, only to replace it with a value instead of keeping the formula. Do the formula in a variable instead, then place it in the cell.

You have several If blocks in a row doing a similar thing -

If Not Range Is Nothing Then
Range.Find
Range.EntireRow.Cut
Range.Insert xlShiftDown
Set Range = Nothing

That .Find, .Cut and .Insert are all very slow. Why not bring it all into an array, make the changes in the array and then put the array back

• tjb1: Thank you very much for your input! ByVal vs ByRef - If I understand this correctly I should be passing a value and then defining the type in the receiving code? Also in the section about performance, specifically the large formula being placed on the sheet. I went this route because leaving the formula was very slow, are you saying it would be faster to use 'Application.WorksheetFunction' to find the value and then place it in rather than calculating and replacing with a value?
• tjb1: As for the end, I don't understand how I can do this in an array. In the beginning I am placing a large amount of data starting at a certain row. The sheet has several rows above it that are meant to hold data matching certain dates so after the code finds all of the data and creates a range, these ranges are moved into the correct row.
• Raystafarian: Yes, pass byval and have the function return what you want. It's always faster to do the calculation behind the scenes and then put the values on the sheet. As for the array - you can sort the array, or maybe that's just not something that works for this project.