I apologize if the title is vague. I did not know how else to reference this question.
I have code which forces the length of any TL values to be a length of 6 numbers following "TL-", and does the same with CT values to a length of 4 following "CT-". If it is too short, 0s are added after "TL-"; if it is too long, 0s are deleted from right after "TL-".
TL- 0012 -> TL-000012
TL-0008981 -> TL-008981
TL - 008 -> TL-000008
The code gets the 6 numbers after finding a string "TL", puts "TL-" in the cell and then the six numbers. I have run into a few problems that I have not been succesful in fixing.
MAIN ISSUE: If are more numbers present, it will grab all of those numbers.
One of the other troubleshoot issues that came up was if there is another TL value, it would grab all the numbers and add it. Now, it will see that string "TL" occurs for a second time, and delete it and anything following it. I hope to apply the same type of fix on the other issues.
Example Output:
Start: Output:
TL-000487 #3 5/7" Cutter TL-487357
TL-000037(N123t3-01) TL-37123301
TL-000094 CTAT15123 TL-9415123
TL-000187 TL-00017 TL-000678 TL-000187
TL-000205 TL-000189 TL-000205
TL-000996:.096 REAMER TL-996096
TL-002313-(MF-4965) TL-23134965
Desired Output:
Start: Output:
TL-000487 #3 5/7" Cutter TL-000487
TL-000037(N123t3-01) TL-000037
TL-000094 CTAT15123 TL-000094
TL-000187 TL-00017 TL-000678 TL-000187
TL-000205 TL-000189 TL-000205
TL-000996:.096 REAMER TL-000996
TL-002313-(MF-4965) TL-002313
If anyone could help me troubleshoot these issues, I would find it most informative and helpful.
CODE:
'force length of TL/CT to be 6/4 numbers long, eliminate spaces
Dim str As String, ret As String, tmp As String, j As Integer, k As Integer
For k = 2 To StartSht.Range("C2").End(xlDown).Row
ret = ""
str = StartSht.Range("C" & k).Value
'for TL numbers
If InStr(str, "TL") > 0 Then
'if more than one TL value, delete everything after the first TL number
If InStr(3, str, "TL") > 0 Then str = Mid(str, 1, InStr(3, str, "TL") - 2)
For j = 1 To Len(str)
tmp = Mid(str, j, 1)
If IsNumeric(tmp) Then ret = ret + tmp
Next j
'force to 6 numbers if too short; add 0s immediately after "TL-"
For j = Len(ret) + 1 To 6
ret = "0" & ret
Next j
'force to 6 numbers if too long; eliminate 0s immediately after "TL-"
If Len(ret) > 6 Then
Debug.Print Len(ret)
For j = Len(ret) To 7 Step -1
If Mid(ret, 1, 1) = "0" Then
ret = Right(ret, j - 1)
End If
Next j
End If
'eliminate superfluous spaces around "TL-"
ret = "TL-" & ret
StartSht.Range("C" & k).Value = ret
'for CT numbers
ElseIf InStr(str, "CT") > 0 Then
For j = 1 To Len(str)
tmp = Mid(str, j, 1)
If IsNumeric(tmp) Then ret = ret + tmp
Next j
'force to 4 numbers if too short; add 0s immediately after "CT-"
For j = Len(ret) + 1 To 4
ret = "0" & ret
Next j
'force to 4 numbers if too long; eliminate 0s immediately after "CT-"
If Len(ret) > 4 Then
Debug.Print Len(ret)
For j = Len(ret) To 5 Step -1
If Mid(ret, 1, 1) = "0" Then
ret = Right(ret, j - 1)
End If
Next j
End If
'eliminate superfluous spaces around "CT-"
ret = "CT-" & ret
StartSht.Range("C" & k).Value = ret
End If
Next k
EDIT: CT issues
It is now
Start: Output:
CT-0087 (TC-7988) CT-0087
CT-0067-02 CT-0067
CT-0076-REV01 CT-0076
CT-0098-1 A CT-0098
I want it to be
Start: Desired Output:
CT-0087 (TC-7988) CT-0087
CT-0067-02 CT-0067-02
CT-0076-REV01 CT-0076-01
CT-0098-1 A CT-0098-1
So there should always be a "-" and a maximum of 2 numbers to grab, but I would only want it to grab it if the dash is immediately following (CT-0087 (TC-7988) should not be CT-0087-79) and I do not know how to throw an exception for that particular issue. Ideas?
There are a couple things that I would do differently.
Instr
function in a variableFormat$
function. To remove leading zeroes, you can convert the string into a long using CLng
.Here is the function:
Public Function ExtractNumberWithLeadingZeroes(ByRef theWholeText As String, ByRef idText As String, ByRef numCharsRequired As Integer) As String
' Finds the first entry of idText in theWholeText
' Returns the first number found after idText formatted
' with leading zeroes
Dim i As Integer
Dim j As Integer
Dim thisChar As String
Dim returnValue As String
Dim tmpText As String
Dim firstPosn As Integer
Dim secondPosn 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
' Find first number
For j = 1 To Len(tmpText)
If IsNumeric(Mid(tmpText, j, 1)) Then
tmpText = Mid(tmpText, j)
Exit For
End If
Next j
' Find where the numbers end
returnValue = tmpText
For j = 1 To Len(returnValue)
thisChar = Mid(returnValue, j, 1)
If Not IsNumeric(thisChar) Then
returnValue = Mid(returnValue, 1, j - 1)
Exit For
End If
Next j
'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
returnValue = Format$(CLng(returnValue), String(numCharsRequired, "0"))
End If
ExtractNumberWithLeadingZeroes = returnValue
End Function
You call this function like this:
ret = ExtractNumberWithLeadingZeroes(str, "TL", 6)
And you get something like "000487".
Your original block of code becomes:
'force length of TL/CT to be 6/4 numbers long, eliminate spaces
Dim str As String, ret As String, k As Integer
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
EDIT: OP clarified his position so I've re-written the ExtractNumberWithLeadingZeroes
function and included the new version below:
Public Function ExtractNumberWithLeadingZeroes(ByRef theWholeText As String, ByRef idText As String, ByRef numCharsRequired As Integer) As String
' Finds the first entry of idText 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
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
Collected from the Internet
Please contact [email protected] to delete if infringement.
Comments