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
