VBA - optimizing code in functions for faster runtime - vba

Question

The code works very well but before I added sections (13) and (14), it ran in 6 minutes and now runs in 16 minutes. If there is a way to streamline this to cut down the runtime, that would be extraordinary.
Main part of code grabs values from under the header 'CUTTING TOOL' in various opening files in a designated folder. They are then printed to the workbook with code where all the information is printed to, StartSht, and the function alters the output information so that TL- has exactly 6 numbers following it and CT- has 4, plus an extra 2 if there is a "-" after the four numbers (ie CT-0081-01). If less than the specified length, 0s are added immediately after the "-". If greater than the specific length, 0s are deleted immediately after the "-".
Any suggestions on how to potentially streamline this code or general tips would be great. I have tried implementing the tips at this website but not much changed.
Main Code:
With WB
For Each ws In .Worksheets
'(3)
'find CUTTING TOOL on the source sheet
If Not ws.Range("A1:M15").Find(What:="CUTTING TOOL", LookAt:=xlWhole, LookIn:=xlValues) Is Nothing Then
Set hc = ws.Range("A1:M15").Find(What:="CUTTING TOOL", LookAt:=xlWhole, LookIn:=xlValues)
Set dict = GetValues(hc.Offset(1, 0), "SplitMe")
If dict.count > 0 Then
'add the values to the master list, column 3
Set d = StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0)
d.Resize(dict.count, 1).Value = Application.Transpose(dict.items)
Else
'if no items are under the CUTTING TOOL header
StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0) = " "
End If
For k = 2 To StartSht.Range("C2").End(xlDown).Row
ret = ""
str = StartSht.Range("C" & k).Value
ret = ExtractNumberWithLeadingZeroes(str, "TL", 6)
If ret <> "" Then
StartSht.Range("C" & k).Value = "TL-" & ret
Else
'for CT numbers
ret = ExtractNumberWithLeadingZeroes(str, "CT", 4)
If ret <> "" Then
StartSht.Range("C" & k).Value = "CT-" & ret
End If
End If
Next k
...
...
...
Functions:
'(8)
'Get the Values from columns with specified headers
Function GetValues(ch As Range, Optional vSplit As Variant) As Scripting.Dictionary
Dim dict As Scripting.Dictionary
Dim dataRange As Range
Dim cell As Range
Dim theValue As String
Dim splitValues As Variant
Dim counter As Long
Set dict = New Scripting.Dictionary
Set dataRange = ch.Parent.Range(ch, ch.Parent.Cells(Rows.count, ch.Column).End(xlUp)).Cells
' If there are no values in this column then return an empty dictionary
' If there are no values in this column, the dataRange will start at the row
' *above* ch and end at ch
If (dataRange.Row = (ch.Row - 1)) And (dataRange.Rows.count = 2) And (Trim(ch.Value) = "") Then
GoTo Exit_Function
End If
For Each cell In dataRange.Cells
counter = counter + 1
theValue = Trim(cell.Value)
If Len(theValue) = 0 Then
theValue = " "
End If
'exclude any info after ";"
If Not IsMissing(vSplit) Then
splitValues = Split(theValue, ";")
theValue = splitValues(0)
End If
'exclude any info after ","
If Not IsMissing(vSplit) Then
splitValues = Split(theValue, ",")
theValue = splitValues(0)
End If
If Not dict.exists(theValue) Then
dict.Add counter, theValue
End If
Next cell
Exit_Function:
Set GetValues = dict
End Function
'(9)
'find a header on a row: returns Nothing if not found
Function HeaderCell(rng As Range, sHeader As String) As Range
Dim rv As Range, c As Range
For Each c In rng.Parent.Range(rng, rng.Parent.Cells(rng.Row, Columns.count).End(xlToLeft)).Cells
'copy cell value if it contains some string "holder" or "cutting tool"
If Trim(c.Value) = sHeader Then
'If InStr(c.Value, sHeader) <> 0 Then
Set rv = c
Exit For
End If
Next c
Set HeaderCell = rv
End Function
'(10)
'gets the last row in designated column
Function GetLastRowInColumn(theWorksheet As Worksheet, col As String)
With theWorksheet
GetLastRowInColumn = .Range(col & .Rows.count).End(xlUp).Row
End With
End Function
'(11)
'gets the last row in designated sheet
Function GetLastRowInSheet(theWorksheet As Worksheet)
Dim ret
With theWorksheet
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
ret = .Cells.Find(What:="*", _
After:=.Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Else
ret = 1
End If
End With
GetLastRowInSheet = ret
End Function
'(12)
'get the file name without the extension
Function GetFilenameWithoutExtension(ByVal FileName)
Dim Result, i
Result = FileName
i = InStrRev(FileName, ".")
If (i > 0) Then
Result = Mid(FileName, 1, i - 1)
End If
GetFilenameWithoutExtension = Result
End Function
'(13)
Public Function ExtractNumberWithLeadingZeroes(ByRef theWholeText As String, ByRef idText As String, ByRef numCharsRequired As Integer) As String
' Finds the first entry of idText, TL/CT, in theWholeText
' Returns the first number found after idText formatted with leading zeroes
Dim returnValue As String
Dim extraValue As String
Dim tmpText As String
Dim firstPosn As Integer
Dim secondPosn As Integer
Dim ctNumberPosn As Integer
returnValue = ""
firstPosn = InStr(1, theWholeText, idText)
If firstPosn > 0 Then
' remove any text before first idText, also remove the first idText
tmpText = Mid(theWholeText, firstPosn + Len(idText))
'if more than one idText value, delete everything after (and including) the second idText
secondPosn = InStr(1, tmpText, idText)
If secondPosn > 0 Then
tmpText = Mid(tmpText, 1, secondPosn)
End If
returnValue = ExtractTheFirstNumericValues(tmpText, 1)
If idText = "CT" Then
ctNumberPosn = InStr(1, tmpText, returnValue)
' Is the next char a dash? If so, must include more numbers
If Mid(tmpText, ctNumberPosn + Len(returnValue), 1) = "-" Then
' There are some more numbers, after the dash, to extract
extraValue = ExtractTheFirstNumericValues(tmpText, ctNumberPosn + Len(returnValue))
End If
End If
'force to numCharsRequired numbers if too short; add 0s immediately after idText
'force to numCharsRequired numbers if too long; eliminate 0s immediately after idText
' The CLng gets rid of leading zeroes and the Format$ adds any required up to numCharsRequired chars
If returnValue <> "" Then
returnValue = Format$(CLng(returnValue), String(numCharsRequired, "0"))
If extraValue <> "" Then
returnValue = returnValue & "-" & extraValue
End If
End If
End If
ExtractNumberWithLeadingZeroes = returnValue
End Function
'(14)
Private Function ExtractTheFirstNumericValues(ByRef theText As String, ByRef theStartingPosition As Integer) As String
Dim i As Integer
Dim j As Integer
Dim tmpText As String
Dim thisChar As String
' Find first number
For i = theStartingPosition To Len(theText)
If IsNumeric(Mid(theText, i, 1)) Then
tmpText = Mid(theText, i)
Exit For
End If
Next i
' Find where the numbers end
For j = 1 To Len(tmpText)
thisChar = Mid(tmpText, j, 1)
If Not IsNumeric(thisChar) Then
tmpText = Mid(tmpText, 1, j - 1)
Exit For
End If
Next j
ExtractTheFirstNumericValues = tmpText
End Function

Answer 1

have you put in break point to see which parts are taking the time ? For example is the For loop in the first part taking very much time ? The easiest way i can see you could speed things up is any time you do a Loop, For Each Cell instead set a variable equal to that range and loop through the variable. This can insanely increase speed especially if your touch a lot of cells. In my experience basically anything to do with cells is the slowest thing in excel. I often convert everything to variables, do all my work, then drop it back down when i am done. I have cut things for 2 hours to 2 minutes doing this.
Make it faster?

Answer 2

A large time saver was moving the section of code that the two functions are called from outside of the looping through files. That way, it would not stop after every file to fix it but rather fix all of the final output at the end. Cut the runtime in half!