3
\$\begingroup\$

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

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

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

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.