Another difficult task for me...
I have a excel sheet like this...
In the first column there are two Aas, their values are shown in the second column, which is A string and Astring.
A string and Astring differ only from one blank key. I want to use excel VBA to say, these two values are equal, as long as they are same in the first column, but differ only from one letter in the second column. One of them should be deleted then. [shown in the "target" part]
Similarly, there are two Dds, their values differ only from a ;.
Here I wrote some code, but I dont know how to do the if algorithmus.
Sub deletesimilars()
Dim lr As Long
lr = ActiveSheet.UsedRange.Rows.Count
For i = lr To 1 Step -1 'reverse loop
If Cells(i, 1) = Cells(i - 1, 1) Then
' if cells(i,2) ??? cells(i-1,2) then ' I stuck here
Cells(i, 1) = ""
Cells(i, 2) = ""
End If
End If
Next i
End Sub
Thanks!!!
I've run into this previous in my work, when I want to guarantee the "equivalence" of certain string. So my technique is to "normalize" the strings by focusing on the important content of the string.
In most of my cases, this means:
stripping all whitespace (usually not important anyway)
converting everything to lowercase (case is often not important to me)
sometimes ignoring certain special characters
So I have a utility function called NormalizeString that performs these actions.
Your code then becomes:
Option Explicit
Sub DeleteSimilars()
Dim thisSH As Worksheet
Dim lastRow As Long
Set thisSH = ActiveSheet
lastRow = thisSH.UsedRange.Rows.Count
Dim i As Long
For i = lastRow To 2 Step -1
If thisSH.Cells(i, 1) = thisSH.Cells(i - 1, 1) Then
If NormalizeString(thisSH.Cells(i, 2), ";") = _
NormalizeString(thisSH.Cells(i - 1, 2), ";") Then
thisSH.Cells(i, 1) = vbNullString
thisSH.Cells(i, 2) = vbNullString
End If
End If
Next i
End Sub
Function NormalizeString(ByVal inputStr As String, _
Optional ByVal specialChars As String) As String
'--- "normalizes" a string by a series of modifications, such as
' -- removes all whitespace
' -- converts all characters to lowercase
' -- removes other "special" characters that should not
' be considered part of the string
Dim returnString As String
returnString = Replace(inputStr, " ", "", , , vbTextCompare)
returnString = LCase(returnString)
If Not IsMissing(specialChars) Then
Dim i As Integer
For i = 1 To Len(specialChars)
returnString = Replace(returnString, _
Mid(specialChars, i, 1), "", , , vbTextCompare)
Next i
End If
NormalizeString = returnString
End Function
Related
I have created a VBA code to remove all special characters available in a column. As an example I have a Alphanumeric character with some special characters in every cells of a column:
Suppose in a cell I have a value: abc#123!-245
After executing my code I got output abc 123 245
Here my code is working fine to remove all the special characters. My code is given below:
Sub ReplaceSpecial()
Dim cel As Range
Dim strVal As String
Dim i As Long
Application.ScreenUpdating = False
For Each cel In Selection
strVal = cel.Value
For i = 1 To Len(strVal)
Select Case Asc(Mid(strVal, i, 1))
Case 32, 48 To 57, 65 To 90, 97 To 122
' Leave ordinary characters alone
Case Else
Mid(strVal, i, 1) = " "
End Select
Next i
cel.Value = strVal
Next cel
Application.ScreenUpdating = True
End Sub
Now if I want to remove the space for my output so that output should look like abc123245, how to do that in VBA?
Input: abc#123!-245
Current Output: abc 123 245
Required Output: abc123245
You could construct a new string with just the permitted characters.
Sub ReplaceSpecial()
Dim cel As Range
Dim strVal As String, temp As String
Dim i As Long
Application.ScreenUpdating = False
For Each cel In Selection
strVal = cel.Value
temp = vbNullString
For i = 1 To Len(strVal)
Select Case Asc(Mid(strVal, i, 1))
Case 32, 48 To 57, 65 To 90, 97 To 122
temp = temp & Mid(strVal, i, 1)
End Select
Next i
cel.Value = temp
Next cel
Application.ScreenUpdating = True
End Sub
My sole intention for this late post was to
test some features of the â–ºApplication.Match() function (comparing a string input against valid characters) and to
demonstrate a nice way to "split" a string into single characters as alternative and possibly instructive solution (see help function String2Arr()).
I don't intend, however to show better or faster code here.
Application.Match() allows not only to execute 1 character searches in an array, but to compare even two arrays in one go,
i.e. a character array (based on an atomized string input) against an array of valid characters (blanks, all digits and chars from A to Z).
As Application.Match is case insensitive, it suffices to take e.g. lower case characters.
All findings of input chars return their position in the valid characters array (otherwise resulting in Error 2042).
Furthermore it was necessary to exclude the wild cards "*" and "?", which would have been considered as findings otherwise.
Function ValidChars(ByVal s, Optional JoinResult As Boolean = True)
'Purp: return only valid characters if space,digits,"A-Z" or "a-z"
'compare all string characters against valid characters
Dim tmp: tmp = foundCharAt(s) ' get array with found positions in chars
'overwrite tmp array
Dim i As Long, ii As Long
For i = 1 To UBound(tmp)
If IsNumeric(tmp(i)) Then ' found in valid positions
If Not Mid(s, i, 1) Like "[?*]" Then ' exclude wild cards
ii = ii + 1
tmp(ii) = Mid(s, i, 1) ' get char from original string
End If
End If
Next
ReDim Preserve tmp(1 To ii) ' reduce to new size
'join tmp elements to resulting string (if argument JoinResult = True)
ValidChars = IIf(JoinResult, Join(tmp, ""), tmp)
End Function
Help function foundCharAt()
Returns an array of found character positions in the valid chars array:
Function foundCharAt(ByVal s As String) As Variant
'Purp: return array of found character positions in chars string
'Note: (non-findings show Error 2042; can be identified by IsError + Not IsNumeric)
Dim chars: chars = String2Arr(" 0123456789abcdefghijklmnopqrstuvwxyz")
foundCharAt = Application.Match(String2Arr(s), chars, 0)
End Function
Help function String2Arr()
Assigns an array of single characters after atomizing a string input:
Function String2Arr(ByVal s As String) As Variant
'Purp: return array of all single characters in a string
'Idea: https://stackoverflow.com/questions/13195583/split-string-into-array-of-characters
s = StrConv(s, vbUnicode)
String2Arr = Split(s, vbNullChar, Len(s) \ 2)
End Function
Use a regular expression's object and replace all unwanted characters by using a negated character class. For demonstration purposes:
Sub Test()
Dim str As String: str = "abc#123!-245"
With CreateObject("vbscript.regexp")
.Global = True
.Pattern = "[^0-9A-Za-z ]"
str = .Replace(str, "")
End With
Debug.Print str
End Sub
The pattern [^0-9A-Za-z ] is a negated character class and captured everything that is not a alphanumeric or a space character. You'll find a more in-depth explaination in this online demo.
At time of writing I'm unsure if you want to leave out the space characters or not. If so, just remove the space from the pattern.
Thought I'd chuck in another alternative using the Like() operator:
For i = Len(str) To 1 Step -1
If Mid(str, i, 1) Like "[!0-9A-Za-z ]" Then
str= Application.Replace(str, i, 1, "")
End If
Next
Or with a 2nd string-type variable (as per #BigBen's answer):
For i = 1 to Len(str)
If Mid(str, i, 1) Like "[0-9A-Za-z ]" Then
temp = temp & Mid(str, i, 1)
End If
Next
If you want to build on your current effort, replace:
cel.Value = strVal
with:
cel.Value = Replace(strVal, " ", "")
Consider:
Sub ReplaceSpecial()
Dim cel As Range
Dim strVal As String
Dim i As Long
Application.ScreenUpdating = False
For Each cel In Selection
strVal = cel.Value
For i = 1 To Len(strVal)
Select Case Asc(Mid(strVal, i, 1))
Case 32, 48 To 57, 65 To 90, 97 To 122
' Leave ordinary characters alone
Case Else
Mid(strVal, i, 1) = " "
End Select
Next i
cel.Value = Replace(strVal, " ", "")
Next cel
Application.ScreenUpdating = True
End Sub
I would like to print each substrings in between the "..." from this string: "...covid...is...very...scary" in consecutive cells in a column in excel.
this is my code in VBA.
Sub copyd()
findandcopy("...covid...is...very...scary") 'not sure how to print in consecutive cells of a column
End Sub
Function findandcopy(brokenstr As String) As String
Dim first, second As Integer
Dim strtarget as string
strtarget = "..."
Do until second =0. 'second=0 so that loop ends when there is no more "..." found
first = InStr(brokenstr, strtarget)
second = InStr(first + 3, brokenstr, strtarget)
findandcopy = Mid(purpose, first +3, second - first -3) 'referred to https://stackoverflow.com/questions/2543225/how-to-get-a-particular-part-of-a-string#_=_
first = second 'so that loop can find next "..."
Loop
End Function
can anyone please advise? thank you for your help :)
Try this code:
Option Explicit
Sub copyd()
Dim arr As Variant
' get splitted text into horizontal array arr()
arr = Split("...covid...is...very...scary", "...")
If UBound(arr) > 0 Then ' if there is something in the array, display it on the sheet
' put onto sheet values from transposed array arr()
ThisWorkbook.Worksheets(1).Range("A1"). _
Resize(UBound(arr) + 1, 1).Value = _
WorksheetFunction.Transpose(arr)
End If
End Sub
Ahh, why not just split the string by "..."?
Like:
Function findandcopy(brokenstr As String, targetStr as string)
dim substr()
if instr(1, brokenstr, targetStr, vbTextCompare) > 0 then
'brokenstr has at least one instance of targetStr in it
brokenstr2 = split(brokenstr,targetStr)
if brokenstr2(0) = "" then
redim substr(ubound(brokenstr2)-1)
iStart = 1
else
redim substr(ubound(brokenstr2))
iStart = 0
end if
for i = iStart to ubound(brokenstr2)
substr(i-iStart) = brokenstr2(i)
next i
else
'No instances of targetStr in brokenstr
redim substr(0)
substr(0) = brokenstr
end if
findandcopy = substr
end function
Which will return an array of strings which are the bits between targetStr. Then you can do with it as you please within the parent sub.
If you start doing comparisons with the results and find issues - you can remove whitespace by modifying above as:
substr(i) = trim(brokenstr2(i))
and your calling code:
Sub main()
Dim covid as string
Dim remove as string
covid = "...covid...is....very...scary"
'covid = "really...covid...is...very...scary" 'For testing
remove = "..."
rtn = findandcopy(covid, remove)
end sub
How can I convert text to column when the text is unstructured with no proper delimiters.
For example, how can i turn the following lines:
Into something like:
In Excel the Text to columns don't seem to find the right separator (space, tab,...). I tried in VBA with the following:
I1 = Mid(Cells(i, 1), 1, 16)
I2 = Mid(Cells(i, 1), 17, 33)
I3 = Mid(Cells(i, 1), 34, 49)
I4 = Mid(Cells(i, 1), 50, 53)
I5 = Mid(Cells(i, 1), 54, 66)
I6 = Mid(Cells(i, 1), 67, 82)
I7 = Mid(Cells(i, 1), 83, 99)
I8 = Mid(Cells(i, 1), 100, 116)
I9 = Mid(Cells(i, 1), 117, 133)
But I get it doesn't work for all columns. For example, for I3 I get many more values that expected like:
I tried also replacing the tab (in case it existed) like:
MyString = Replace(MyString, vbTab, "")
But didn't work either.
Is there another way to approach it?
Here is an attempt using a custom ReplaceWhitespace function, which replaces sections of whitespace in turn depending on their length. As an intermediate step whitespace is replaced with semicolons; unnecessary semicolons are removed as a last step. Split is used to read the parsed string to an array, and the array is used to read the result to the worksheet. It should be straightforward to tweak ReplaceWhitespace for your specific needs.
Note that this algorithm does not evaluate whether instances of a single whitespace character should be treated as noise (as in "TUBELINES UNASSIGNED") or ar as valid word delimter (as in "Unit Cost"). Therefore, single whitespace as noise is treated as special cases in ReplaceWhitespace: "- -" ~~> "-;-" and " UNASSIGNED " ~~> ";UNASSIGNED;"
Assuming your data from the screenshot is located in range A1:A4, this code produces more or less the desired output, as shown in the screenshot below.
EDIT: The initial design of ReplaceWhitespace was based on trial and error. With a little afterthought I realized that patterns where the number of whitespace characters or semicolons is a composite number will be taken care of by those lines in the algorithm that looks for patterns where the number of characters is a prime number. I have updated the code accordingly.
Sub ParseUnstructured()
Dim i As Long
For Each cell In Range("A1:A4")
i = i + 1
' Clean whitespace:
sRow = ReplaceWhitespace(cell.Value)
' Read to array
Dim sArray() As String
sArray() = Split(sRow, ";")
' Read to worksheet:
Range("A1").Offset(5 + i).Resize(1, UBound(sArray)+1).Value = sArray
Next cell
End Sub
Function ReplaceWhitespace(sInput As String) As String
Dim sOutput As String
' Look for special cases with single-whitespace noise:
sOutput = Replace(sInput, "- -", "-;-") ' Take care of "----- ----"
sOutput = Replace(sOutput, "UNASSIGNED", ";UNASSIGNED;")
' Look for patterns where the number of "noise" characters is a prime number:
sOutput = Replace(sOutput, " ", ";") ' 7 whitespaces
sOutput = Replace(sOutput, " ", ";") ' 5
sOutput = Replace(sOutput, " ", ";") ' 3
sOutput = Replace(sOutput, " ", ";") ' 2
' sOutput = Replace(sOutput, " ", "_") ' 1 Optional
sOutput = Replace(sOutput, ";;;;;", ";") ' 5 semicolons
sOutput = Replace(sOutput, ";;;", ";") ' 3
sOutput = Replace(sOutput, ";;", ";") ' 2
sOutput = Replace(sOutput, "; ", ";") ' Takes care of some leftovers.
ReplaceWhitespace = sOutput
End Function
Result from running ParseUnstructured():
The data you present does have a regular pattern, assuming that the Category can only be one of a few defined words.
One could also assume that UOM has only a few defined words, if Category will only ever be a single word. For example
Item: First substring followed by a space
Description: Variable number of words followed by Category
Category: From list of defined words
UOM: From list of defined words
And then the remainder are all space separated.
From that pattern, we can construct a Regular Expression, and use that in a VBA macro to split the line.
Of course, if the pattern varies from that, the method won't work. But you'll have to provide examples which encompass all of the variability.
The macro below assumes that Category will be either ASSIGNED or UNASSIGNED, but you can add more words to the pipe-separated list in the code.
Other assumptions are in the code.
Option Explicit
Sub parseLine()
Dim WS As Worksheet, R As Range, C As Range
Dim RE As Object, MC As Object
Dim vRes As Variant, I As Long
'Set original worksheet/range
'change to suit
'Below uses column A
Set WS = Worksheets("sheet1")
With WS
Set R = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With
'Initialize regex engine
Set RE = CreateObject("vbscript.regexp")
With RE
.Pattern = "^(\S+)\s+(.*)\s*\b(UNASSIGNED|ASSIGNED)\b\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)"
.IgnoreCase = False
.MultiLine = True
.Global = True
End With
'Iterate through; create the Parse line and parse
Application.ScreenUpdating = False
For Each C In R
If RE.Test(C.Text) = True Then
Set MC = RE.Execute(C.Text)
ReDim vRes(1 To MC(0).SubMatches.Count)
For I = 1 To UBound(vRes)
vRes(I) = MC(0).SubMatches(I - 1)
Next I
'write the results next to the column)
With C.Offset(0, 1).Resize(columnsize:=UBound(vRes))
.Clear
.NumberFormat = "#"
.Value = vRes
.EntireColumn.AutoFit
End With
End If
Next C
Application.ScreenUpdating = True
End Sub
How can I set up a macro that will strip the letters from #####XX in column I and put them in to column L same row? Thanks!
Assuming you're working with the first sheet and you're always stripping off the last two characters while leaving the first 5 characters, the following code will work:
Public Sub StripOff()
Dim iRow as Integer
iRow = 2 'Assuming row 1 is headers, else make this 1
While Sheets(1).Range("I" + Cstr(iRow)).Value <> ""
Sheets(1).Range("L" + CStr(iRow)).Value = Right(Sheets(1).Range("I" + Cstr(iRow)).Value, 2)
Sheets(1).Range("I" + Cstr(iRow)).Value = Left(Sheets(1).Range("I" + Cstr(iRow)).Value, 5)
iRow = iRow + 1
Wend
End Sub
The operative words I'm understanding from your question are Cutting and strip. To my mind, this means that the last two letters are permanently removed from column I and placed in column L.
Sub cut2right()
Dim v As Long, vPFXS As Variant, vSFXS As Variant
With Worksheets("Sheet6")
vPFXS = .Range(.Cells(2, "I"), .Cells(Rows.Count, "I").End(xlUp))
ReDim vSFXS(1 To UBound(vPFXS), 1 To 1)
For v = LBound(vPFXS, 1) To UBound(vPFXS, 1)
If Len(vPFXS(v, 1)) > 1 Then
vSFXS(v, 1) = Right(vPFXS(v, 1), 2)
vPFXS(v, 1) = Left(vPFXS(v, 1), Len(vPFXS(v, 1)) - 2)
End If
Next v
.Cells(2, "I").Resize(UBound(vPFXS, 1), 1) = vPFXS
.Cells(2, "L").Resize(UBound(vPFXS, 1), 1) = vSFXS
End With
End Sub
Working with variant arrays should speed up working with many cells with variable length string values. If they were all the same length then manually running a Text-to-Columns command with a fixed length to an unused column and then copying and pasting the results to the appropriate column would have done just fine.
You can get the leading numeric characters from a string using the VBA Val function. To use this function on a worksheet you will need to create a User Defined Function (UDF) in a standard VBA module.
Function LeadingNumbers(Str As String) As Double
LeadingNumbers = Val(Str)
End Function
Simply enter the function in a cell and reference the cell containing the string you want "cleaned".
I am hoping someone could help me out with a VBA Excel macro.
I have received a worksheet in Excel 2007 which contains product names in one column, and I need to sort this into a logical format so I can use it. However, the list itself is not in any kind of logical order, is 10 000 rows long and I am going to have to do this every month!!
Basically, what I would like to do is search for certain keywords which are common to most of the entries and move them into separate cells in different columns (but in the same row as the original entry).
Regarding keywords: There are 3 different types, two of which I have a complete list of.
Example of keywords: some are measures such as cm (centimetre), mm (millimetre), m (metre) etc.). Then there are other keywords such as % and finally a last set of keywords which is wood, plastic, glass etc.
If this was not complicated enough, the measures (cm for example) are duplicated in some instances and are important details so I cant just separate them but would ideally like them in two adjacent cells.
Fortunately, there is a space after each measure, % sign and item material.
Working from right to left is the easiest way I can think of achieving this as the first description in the string varies wildly between entries and that can stay as is.
So, below is an example string, lets say this is in Cell A1. (Inverted commas are not included in the string and the word "by" appears in only about 100 cases. Usually it is missing...)
"Chair Leg Wood 100% 1m by 20cm"
I would ideally like for the string to be split up into cells as follows
Cell B1 - Chair Leg
Cell C1 - Wood
Cell D1 - 1m
Cell E1 - 2cm
Cell F1 - 100%
Having the % measures in the same column would be extremely helpful
Can anyone please help me with this or the beginnings of a macro which does this and then moves down the list - I have tried using some basic "find" and "len" formulas but really am at my wits end on how to deal with this!
The task boils down to defining a robust definition of the structure of the input data.
Form the info provided a candidate definition might be
<Description, one or more words> <Material, one word> <A value followd by %> <Dimension A> <optional "by"> <Dimension B>
The following macro will process data that conforms this this spec. The definition may need
expanding, eg two word materials (eg Mild Steel)
You will need to add error handling in case any rows don't conform, eg no % in the string, or % character elsewhere in string
Option Explicit
Dim dat As Variant
Sub ProcessData()
Dim r As Range
Dim i As Long
Set r = Intersect(ActiveSheet.UsedRange, ActiveSheet.Columns(1)).Resize(, 5)
dat = r
For i = 1 To UBound(dat, 1)
ParseRow i, CStr(dat(i, 1))
Next
r = dat
ActiveSheet.Columns(5).Style = "Percent"
End Sub
Sub ParseRow(rw As Long, s As String)
'Chair Leg Wood 100% 1m by 20cm
Dim i As Long
Dim sDim As String, sPCnt As String, sMat As String, sDesc As String
Dim sA As String, sB As String
i = InStr(s, "% ")
sDim = Trim(Replace(Mid(s, i + 2), " by ", " ")) ' text to right of %, remove "by"
sA = Trim(Left(sDim, InStr(sDim, " "))) ' split dimension string in two
sB = Trim(Mid(sDim, InStr(sDim, " ")))
s = Left(s, i)
i = InStrRev(s, " ")
sPCnt = Mid(s, i + 1) ' text back to first space before %
s = Trim(Left(s, i))
i = InStrRev(s, " ") ' last word in string
sMat = Mid(s, i + 1)
sDesc = Trim(Left(s, i)) ' whats left
dat(rw, 1) = sDesc
dat(rw, 2) = sMat
dat(rw, 3) = sA
dat(rw, 4) = sB
dat(rw, 5) = sPCnt
End Sub
First, I'd use the Split function to separate the parts into an array, this will avoid most of the string functions and string math:
Dim parts As Variant
parts = Split(A1)
Then, I'd do my comparisons to each part.
Finally, I'd concatenate the parts I didn't breakout, and place all parts on the sheet.
This is based on your example which has spaces inbetween every part, though something similar could work otherwise, you just have to do more work with each part.
Here's my stab at it. We could use about 10 more examples, but this should be a start. To use, select a one column range with your descriptions and run SplitProduct. It will split it out to the right of each cell.
Sub SplitProducts()
Dim rCell As Range
Dim vaSplit As Variant
Dim i As Long
Dim aOutput() As Variant
Dim lCnt As Long
Const lCOLDESC As Long = 1
Const lCOLMAT As Long = 2
Const lCOLPCT As Long = 3
Const lCOLREM As Long = 4
If TypeName(Selection) = "Range" Then
If Selection.Columns.Count = 1 Then
For Each rCell In Selection.Cells
'split into words
vaSplit = Split(rCell.Value, Space(1))
ReDim aOutput(1 To 1, 1 To 1)
'loop through the words
For i = LBound(vaSplit) To UBound(vaSplit)
Select Case True
Case IsPercent(vaSplit(i))
'percents always go in the same column
lCnt = lCOLPCT
If UBound(aOutput, 2) < lCnt Then
ReDim Preserve aOutput(1 To 1, 1 To lCnt)
End If
aOutput(1, lCnt) = vaSplit(i)
Case IsInList(vaSplit(i))
'list items always go in the same column
lCnt = lCOLMAT
ReDim Preserve aOutput(1 To 1, 1 To lCnt)
If UBound(aOutput, 2) < lCnt Then
ReDim Preserve aOutput(1 To 1, 1 To lCnt)
End If
aOutput(1, lCnt) = vaSplit(i)
Case IsMeasure(vaSplit(i))
'measurements go in the last column(s)
If UBound(aOutput, 2) < lCOLREM Then
lCnt = lCOLREM
Else
lCnt = UBound(aOutput, 2) + 1
End If
ReDim Preserve aOutput(1 To 1, 1 To lCnt)
aOutput(1, lCnt) = vaSplit(i)
Case Else
'everything else gets concatentated in the desc column
aOutput(1, lCOLDESC) = aOutput(1, lCOLDESC) & " " & vaSplit(i)
End Select
Next i
'remove any extraneous spaces
aOutput(1, lCOLDESC) = Trim(aOutput(1, lCOLDESC))
'write the values to the left of the input range
rCell.Offset(0, 1).Resize(1, UBound(aOutput, 2)).Value = aOutput
Next rCell
Else
MsgBox "Select a one column range"
End If
End If
End Sub
Function IsPercent(ByVal sInput As String) As Boolean
IsPercent = Right$(sInput, 1) = "%"
End Function
Function IsInList(ByVal sInput As String) As Boolean
Dim vaList As Variant
Dim vaTest As Variant
'add list items as needed
vaList = Array("Wood", "Glass", "Plastic")
vaTest = Filter(vaList, sInput)
IsInList = UBound(vaTest) > -1
End Function
Function IsMeasure(ByVal sInput As String) As Boolean
Dim vaMeas As Variant
Dim i As Long
'add measurements as needed
vaMeas = Array("mm", "cm", "m")
For i = LBound(vaMeas) To UBound(vaMeas)
'any number of characters that end in a number and a measurement
If sInput Like "*#" & vaMeas(i) Then
IsMeasure = True
Exit For
End If
Next i
End Function
No guarantees that this will be speedy on 10k rows.