# Increasing speed of Excel VBA code used for order report

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)=$Y$1" .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($Y$1=1,$B1="""", $Z$1=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

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

### 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


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

• 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 Mar 26 '18 at 14:45
• 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. – tjb1 Mar 26 '18 at 14:49
• 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. – Raystafarian Mar 26 '18 at 21:24