The code works 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 "-".
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
1 Answer 1
Without seeing the rest of the code that makes up your first block of code this is tricky to answer. From helping you with this on SO I remember that you are looping through many files and extracting values from them. I think the problem lies in this code:
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
which actually exists within the loop that opens each file and extracts the values. Inside the For k = 2 ... loop in the block posted just above, you always start at row 2 and read down the whole data. Do you see the problem with this? Each time you paste data from another file, you start again at row 2 on StartSht and read downwards. This means you are running the ExtractNumberWithLeadingZeroes function over the same cells again and again. The first time it produces the number you need but then every subsequent time it is taking in this number, working through it and then giving you back the same result.
You have two options: 1) extract the For k = 2 ... loop from inside the loop that finds the files and just run it afterwards, or 2) use a variable to keep track of the row number at which the new data starts and start the loop there For k = newDataRowNum To StartSht.Range("C2").End(xlDown).Row
ret = ExtractNumberWithLeadingZeroes(...your full code runs in 6 minutes but including the lines it runs in 16 minutes? How many rows of data do you have? (I wrote those functions for you and am surprised they perform so badly) \$\endgroup\$