I have a column in Excel with the format:
A01G45B45D12
I need a way to format it like this, that is divide the string into groups of three characters, sort the groups alphabetically and then join them together with a + sign between:
A01+B45+D12+G45
I wonder it this is possible using the built in formulas in Excel or if I have to do this using VBA or something else, I already have the code for this in C# if there is an easy way to use that from Excel. I have not written plugins for Excel before.
Edit to add:
The above is just an example, the string can be of "any length" but its always divisible by three and the order is random so I cannot assume anything about the order beforehand.
Sub ArraySort()
Dim strStarter As String
Dim strFinish As String
Dim intHowMany As Integer
Dim intStartSlice As Integer
strStarter = ActiveCell.Offset(0, -1).Value 'Pulls value from cell to the left
intHowMany = Int(Len(strStarter) / 3)
ReDim arrSlices(1 To intHowMany) As String
intStartSlice = 1
For x = 1 To intHowMany
arrSlices(x) = Mid(strStarter, intStartSlice, 3)
intStartSlice = intStartSlice + 3
Next x
Call BubbleSort(arrSlices)
For x = 1 To intHowMany
strFinish = strFinish + arrSlices(x) & "+"
Next x
strFinish = Left(strFinish, Len(strFinish) - 1)
ActiveCell.Value = strFinish 'Puts result into activecell
End Sub
Sub BubbleSort(list() As String)
'Taken from power programming with VBA
'It’s a sorting procedure for 1-dimensional arrays named List
'The procedure takes each array element, if it is greater than the next element, the two elements swap positions.
'The evaluation is repeated for every pair of items (that is n-1 times)
Dim First As Integer, Last As Long
Dim i As Long, j As Long
Dim temp As String
First = LBound(list)
Last = UBound(list)
For i = First To Last - 1
For j = i + 1 To Last
If list(i) > list(j) Then
temp = list(j)
list(j) = list(i)
list(i) = temp
End If
Next j
Next i
End Sub
Related
Consider the following example: Lets say you want to make a function "JoinIfs" that works just like SUMIFS except instead of adding the values in the SumRange, it concatenates the values in "JoinRange". Is there a way to nest the ParamArray as it seems to be done in SUMIFS?
SUMIFS(sum_range, criteria_range1, criteria1, [criteria_range2, criteria2], ...)
I imagine the declaration should look something like this:
Function JoinIfs(JoinRange As Variant, _
Delim As String, _
IncludeNull As Boolean, _
ParamArray CritArray(CriteriaRange As Variant, Criteria As Variant)) As String
But nothing I try seems to compile and there might not be a way to nest ParamArrays. But the existence of functions like SUMIFS and COUNTIFS seems to suggest there might be a way to nest the ParamArrays.
This question duplicates AlexR's question Excel UDF with ParamArray constraint like SUMIFS. But that was posted a few years ago with no response so either the question didn't get enough attention or it was misunderstood.
Edit for clarification: This question is specifically about nesting ParamArrays. I'm not trying to find alternative methods of achieving the outcome of the example above. Imagine nesting ParamArrays on a completely different fictional function like "AverageIfs"
As per the documentation for the Function statement and Sub statement, a Function or Sub can only contain 1 ParamArray, and it must be the last argument.
However, you can pass an Array as an Argument to a ParamArray. Furthermore, you can then check how many elements are in the ParamArray, and throw an error if it isn't an even number. For example, this demonstration takes a list of Arrays, and which element in that array to take, and outputs another array with the results:
Sub DemonstrateParamArray()
Dim TestArray As Variant
TestArray = HasParamArray(Array("First", "Second"), 0)
MsgBox TestArray(0)
Dim AnotherArray As Variant
AnotherArray = Array("Hello", "World")
TestArray = HasParamArray(AnotherArray, 0, AnotherArray, 1)
MsgBox Join(TestArray, " ")
End Sub
Function HasParamArray(ParamArray ArgList() As Variant) As Variant
Dim ArgumentCount As Long, WhichPair As Long, Output() As Variant, WhatElement As Long
ArgumentCount = 1 + UBound(ArgList) - LBound(ArgList)
'Only allow Even Numbers!
If ArgumentCount Mod 2 = 1 Then
Err.Raise 450 '"Wrong number of arguments or invalid property assignment"
Exit Function
End If
ReDim Output(0 To Int(ArgumentCount / 1) - 1)
For WhichPair = LBound(ArgList) To ArgumentCount + LBound(ArgList) - 1 Step 2
WhatElement = ArgumentCount(WhichPair + 1)
Output(Int(WhichPair / 2)) = ArgumentCount(WhichPair)(WhatElement)
Next WhichPair
HasParameterArray = Output
End Function
(A list of built-in error codes for Err.Raise can be found here)
It seems like nesting a ParamArray is not possible.
I was hoping to get a function that looks like Excel's built in functions.
SUMIFS, for example seems to group pairs of parameters in a very neat way.
Based on the inputs of some users I made the following Function which seems to work quite well.
Function SJoinIfs(JoinRange As Variant, Sep As String, IncludeNull As Boolean, ParamArray CritArray() As Variant) As Variant
'Concatenates text based on multple criteria similar to SUMIFS.
'Sizes of ranges CritArray (0, 2, 4 ...) must match size of range JoinRange. CritArray must have an even amount of elements
'Elements of CritArray (1, 3, 5 ...) must be single values
Set JoinList = CreateObject("System.Collections.Arraylist")
'Set FinalList = CreateObject("System.Collections.Arraylist")
For Each DataPoint In JoinRange
JoinList.Add (CStr(DataPoint))
Next
JoinArray = JoinList.ToArray
CriteriaCount = UBound(CritArray) + 1
If CriteriaCount Mod 2 = 0 Then
CriteriaSetCount = Int(CriteriaCount / 2)
Set CriteriaLists = CreateObject("System.Collections.Arraylist")
Set CriteriaList = CreateObject("System.Collections.Arraylist")
Set MatchList = CreateObject("System.Collections.Arraylist")
For a = 0 To CriteriaSetCount - 1
CriteriaList.Clear
For Each CriteriaTest In CritArray(2 * a)
CriteriaList.Add (CStr(CriteriaTest))
Next
If CriteriaList.count <> JoinList.count Then 'Ranges are different sizes
SJoinIfs = CVErr(xlErrRef)
Exit Function
End If
MatchList.Add (CStr(CritArray((2 * a) + 1)))
CriteriaLists.Add (CriteriaList.ToArray)
Next
JoinList.Clear
For a = 0 To UBound(JoinArray)
AllMatch = True
For b = 0 To MatchList.count - 1
AllMatch = (MatchList(b) = CriteriaLists(b)(a)) And AllMatch
Next
If AllMatch Then JoinList.Add (JoinArray(a))
Next
SJoinIfs = SJoin(Sep, IncludeNull, JoinList)
Else 'Criteria Array Size is not even
SJoinIfs = CVErr(xlErrRef)
Exit Function
End If
End Function
This function makes use of another function SJoin() which I adapted some time ago based on the answer provided by Lun in his answer to How to replicate Excel's TEXTJOIN function in VBA UDF that allows array inputs.
I have adapted this Function to include the use of Numericals, VBA Arrays and Arraylists as well.
On Error Resume Next
'Sep is the separator, set to "" if you don't want any separator. Separator must be string or single cell, not cell range
'TxtRng is the content you want to join. TxtRng can be string, single cell, cell range or array returned from an array function. Empty content will be ignored
Dim OutStr As String 'the output string
Dim i, j, k, l As Integer 'counters
Dim FinArr(), element As Variant 'the final array and a temporary element when transfering between the two arrays
'Go through each item of TxtRng(), depending on the item type, transform and put it into FinArray()
i = 0 'the counter for TxtRng
j = 0 'the counter for FinArr
k = 0: l = 0 'the counters for the case of array from Excel array formula
Do While i < UBound(TxtRng) + 1
If TypeName(TxtRng(i)) = "String" Then 'specified string like "t"
ReDim Preserve FinArr(0 To j)
FinArr(j) = "blah"
FinArr(j) = TxtRng(i)
j = j + 1
ElseIf TypeName(TxtRng(i)) = "Range" Then 'single cell or range of cell like A1, A1:A2
For Each element In TxtRng(i)
ReDim Preserve FinArr(0 To j)
FinArr(j) = element
j = j + 1
Next
ElseIf TypeName(TxtRng(i)) = "Variant()" Then 'array returned from an Excel array formula
For k = LBound(TxtRng(0), 1) To UBound(TxtRng(0), 1)
For l = LBound(TxtRng(0), 2) To UBound(TxtRng(0), 2)
ReDim Preserve FinArr(0 To j)
FinArr(j) = TxtRng(0)(k, l)
j = j + 1
Next
Next
Else
TJoin = CVErr(xlErrValue)
Exit Function
End If
i = i + 1
Loop
'Put each element of the new array into the join string
For i = LBound(FinArr) To UBound(FinArr)
If FinArr(i) <> "" Then 'Remove this line if you want to include empty strings
OutStr = OutStr & FinArr(i) & Sep
End If
Next
TJoin = Left(OutStr, Len(OutStr) - Len(Sep)) 'remove the ending separator
End Function
Thanks to all who contributed to this question.
Above is a simplified example but what I want to achieve with my UDF is to accept the string in the Collated column and a delimiter which will be used to break the sting apart into substrings and be assigned sequentially to the columns Q1, Q2, Q3, Q4. It is possible for there to be less than 4 substrings generated but there will never be more than 4.
Function DECONS(Subject As String, Delim As String) As String
' takes an input string "Subject" and seperates it using "Delim" as the deliminator
' If the desired element exceeds the number of unique substrings the function returns a blank result
' Hardcoded for max 4 substrings
' initializes temporary variables
Dim i As Long
Dim r() As String
' uses built in VBA function to split the passed string using the deliminating character
r = Split(Subject, Delim)
' increases the size of r() to 4 elements and fills extra elements with blancks
For i = UBound(r) + 1 To 3
ReDim Preserve r(i)
r(i) = ""
Next i
' my sad attempt at what I want to acheive
Dim loT As ListObject
Set loT = ThisWorksheet.ListObjects("TT")
For i = 1 To 4
loT.ListColumn(i + 1).Range.Value = r(i - 1)
Next i
End Function
I've done the text manipulation using the VBA split function which yields an array of strings but I'm hitting a wall as to how to assign the substrings to the relevant columns. My attempt can be seen above. I've done a fair bit of reading but I'm still not comfortable enough in VBA/Excel to figure this out on my own yet. Is this more complex when in a ListObject than outside a table object?
Unfortunately I can't return the string array from the function and then assign it to multiple cells as the Table Object doesn't allow array operations. I had a work around where I would return a specified element, ie the 3rd, and I would call the function in each column and output the one corresponding value. However, the method is not elegant and does a lot of unnecessary repeated computation.
Try
Sub DECONS(Delim As String)
Dim objList As ListObject
Dim vDB As Variant, vSplit
Dim vR(), n As Integer, r As Long
Dim i As Long
Set objList = ActiveSheet.ListObjects("TT")
vDB = objList.DataBodyRange.Columns(1)
r = UBound(vDB, 1)
ReDim vR(1 To r, 1 To 4)
For i = 1 To r
vSplit = Split(vDB(i, 1), "\")
n = 0
For Each v In vSplit
n = n + 1
vR(i, n) = v
Next v
Next i
'Range("b2").Resize(r, 4) = vR
objList.DataBodyRange.Columns(2).Range("a1").Resize(r, 4) = vR
End Sub
I have been banging my head (and a few other heads as well on other Excel programming sites) to get a Combobox in a Userform to sort the rows (coming from two columns in the source spreadsheet) in alpha order.
Ideally, I want a 2 dimensional sort, but at this point, will settle for ONE that works.
Currently, the Combobox, when dropped down, reads in part (minus the bullet points, which do NOT appear and are not needed):
Zoom MRKPayoutPlan
Chuck PSERSFuture
Chuck PSERSCurrent
What I want is:
Chuck PSERSCurrent
Chuck PSERSFuture
Zoom MRKPayoutPlan
The first order is derived from the order in which the rows appear in the source worksheet.
At this point, I am getting a Runtime Error '13', Type Mismatch error. Both fields are text fields (one is last name, the other is a classification code- I want to sort first by name).
Below are the two relevant sections of the VBA code. If someone can help me sort this out, I'll buy at least a virtual round of beers. Excel VBA is not my most comfortable area- I can accomplish this in other apps, but the client spec is that this all must run in Excel alone. Thanks in advance.
Private Sub UserForm_Initialize()
fPath = ThisWorkbook.Path & "\"
currentRow = 4
sheetName = Sheet5.Name
lastRow = Sheets(sheetName).Range("C" & Rows.Count).End(xlUp).Row
Dim rngUID As Range
Dim vList
Set rngUID = Range("vUID")
With rngUID
vList = Application.Index(.Cells, .Parent.Evaluate("ROW(" & .Address & ")"), Array(7, 1))
End With
vList = BubbleSort2D(vList, 2, 1)
With ComboBox1
.ColumnCount = 2
.ColumnWidths = "100;100"
.List = vList
End With
PopulateControls
End Sub
Public Function BubbleSort2D(Strings, ParamArray SortColumns())
Dim tempItem
Dim a As Long
Dim e As Long
Dim f As Long
Dim g As Long
Dim i As String
Dim j As String
Dim m() As String
Dim n
Dim x As Long
Dim y As Long
Dim lngColumn As Long
e = 1
n = Strings
Do While e <> -1
For a = LBound(Strings) To UBound(Strings) - 1
For y = LBound(SortColumns) To UBound(SortColumns)
lngColumn = SortColumns(y)
i = n(a, lngColumn)
j = n(a + 1, lngColumn)
f = StrComp(i, j)
If f < 0 Then
Exit For
ElseIf f > 0 Then
For x = LBound(Strings, 2) To UBound(Strings, 2)
tempItem = n(a, x)
n(a, x) = n(a + 1, x)
n(a + 1, x) = tempItem
Next x
g = 1
Exit For
End If
Next y
Next a
If g = 1 Then
e = 1
Else
e = -1
End If
g = 0
Loop
BubbleSort2D = n
End Function
Here is a bubble sort in VBA source.
Public Sub BubbleSort(ByRef sequence As Variant, _
ByVal lower As Long, ByVal upper As Long)
Dim upperIt As Long
For upperIt = upper To lower + 1 Step -1
Dim hasSwapped As Boolean
hasSwapped = False
Dim bubble As Long
For bubble = lower To upperIt - 1
If sequence(bubble) > sequence(bubble + 1) Then
Dim t as Variant
t = sequence(bubble)
sequence(bubble) = sequence(bubble + 1)
sequence(bubble + 1) = t
hasSwapped = True
End If
Next bubble
If Not hasSwapped Then Exit Sub
Next upperIt
End Sub
Note that using variable names that specify what they are and do instead of single letters makes it easier to read.
As for the 2D sort. Don't. Sort each array individually then sort the array of arrays using the same method. You will need to provide an abstraction to compare the columns. Do not try to sort them both at the same time. I can't think of a scenario where that is a good idea. If for some reason elements can change their sub array in the 2D array, then flatten it into 1 array, sort that and split it back into a 2D array.
Honestly from what I am understanding of you specific problem. You are going from 1D sequence to a 1D sequence so I think 2D arrays are and unnecessary complication.
Instead use a modified bubble sort routine with the comparison statement,
If sequence(bubble) > sequence(bubble +1) Then '...
replaced with a custom comparison function
ComboBoxItemCompare(sequence(bubble), sequence(bubble + 1))
that will return True if the first argument should be swapped with the second.
I'm trying to generate words in Column B from a list of given words in Column A.
Right now my code in Excel VBA does this:
Function GetText()
Dim GivenWords
GivenWords = Sheets(1).Range(Sheets(1).[a1], Sheets(1).[a20])
GetText = A(Application.RandBetween(1, UBound(A)), 1)
End Function
This generates a word from the list I have provided in A1:A20, but I don't want any duplicates.
GetText() will be run 15 times in Column B from B1:B15.
How can I check for any duplicates in Column B, or more efficiently, remove the words temporarily from the list once it has been used?
For example,
Select Range A1:A20
Select one value randomly (e.g A5)
A5 is in Column B1
Select Range A1:A4 and A6:A20
Select one value randomly (e.g A7)
A7 is in Column B2
Repeat, etc.
This was trickier than I thought. The formula should be used as a vertical array eg. select the cells where you want the output, press f2 type =gettext(A1:A20) and press ctrl+shift+enter
This means that you can select where your input words are in the worksheet, and the output can be upto as long as that list of inputs, at which point you'll start getting #N/A errors.
Function GetText(GivenWords as range)
Dim item As Variant
Dim list As New Collection
Dim Aoutput() As Variant
Dim tempIndex As Integer
Dim x As Integer
ReDim Aoutput(GivenWords.Count - 1) As Variant
For Each item In GivenWords
list.Add (item.Value)
Next
For x = 0 To GivenWords.Count - 1
tempIndex = Int(Rnd() * list.Count + 1)
Aoutput(x) = list(tempIndex)
list.Remove tempIndex
Next
GetText = Application.WorksheetFunction.Transpose(Aoutput())
End Function
Here's how I would do it, using 2 extra columns, and no VBA code...
A B C D
List of words Rand Rank 15 Words
Apple =RAND() =RANK(B2,$B$2:$B$21) =INDEX($A$2:$A$21,MATCH(ROW()-1,$C$2:$C$21,0))
copy B2 and C2 down as far as the list, and drag D down for however many words you want.
Copy the word list somewhere, as every time you change something on the sheet (or recalculate), you will get a new list of words
Using VBA:
Sub GetWords()
Dim Words
Dim Used(20) As Boolean
Dim NumChosen As Integer
Dim RandWord As Integer
Words = [A1:A20]
NumChosen = 0
While NumChosen < 15
RandWord = Int(Rnd * 20) + 1
If Not Used(RandWord) Then
NumChosen = NumChosen + 1
Used(RandWord) = True
Cells(NumChosen, 2) = Words(RandWord, 1)
End If
Wend
End Sub
Here is the code. I am deleting the cell after using it. Please make a backup of your data before using this as it will delete the cell contents (it will not save automatically...but just in case). You need to run the 'main' sub to get the output.
Sub main()
Dim i As Integer
'as you have put 15 in your question, i am using 15 here. Change it as per your need.
For i = 15 To 1 Step -1
'putting the value of the function in column b (upwards)
Sheets(1).Cells(i, 2).Value = GetText(i)
Next
End Sub
Function GetText(noofrows As Integer)
'if noofrows is 1, the rand function wont work
If noofrows > 1 Then
Dim GivenWords
Dim rowused As Integer
GivenWords = Sheets(1).Range(Sheets(1).Range("A1"), Sheets(1).Range("A" & noofrows))
'getting the randbetween value to a variable bcause after taking the value, we can delete the cell.
rowused = (Application.RandBetween(1, UBound(GivenWords)))
GetText = Sheets(1).Range("A" & rowused)
Application.DisplayAlerts = False
'deleting the cell as we have used it and the function should not use it again
Sheets(1).Cells(rowused, 1).Delete (xlUp)
Application.DisplayAlerts = True
Else
'if noofrows is 1, there is only one value left. so we just use it.
GetText = Sheets(1).Range("A1").Value
Sheets(1).Cells(1, 1).Delete (xlUp)
End If
End Function
Hope this helps.
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.