I'm trying to create this tool that will, by looking through a list of expenses, be able to calculate the amount owed to each employee. So from our account software I can export an excel document with 2 columns. The first column have the amount and the second will have the following strings:
"Lunch, outlay Tanne"
"Train ticket, outlay Anne"
"Lunch, outlay Dennis"
"Lunch, outlay Anne"
The excel document will then look through all the expenses and calculate the total amount owed to each person. So far I've used the following code to calculate the total amounts (some of the variables are calculated earlier, this is just the part calculating the total amount):
'Calcualte total amount
For i = 1 To NamesTotal
TotalAmount = 0
NameString = UCase(Cells(i + 1, 7))
For j = 1 To EntriesTotal
CellText = UCase(Cells(j + 2, 3))
If InStr(1, CellText, NameString) Then
Amount = Cells(j + 2, 4)
TotalAmount = TotalAmount + Amount
End If
End If
Next
Cells(TableStart + i, 3) = Cells(i + 1, 7)
Cells(TableStart + i, 4) = TotalAmount
Cells(TableStart + i, 4).NumberFormat = "#,##0.00"
Next
The list of names is listed in column 7, the strings in column 3 and amount in column 4. The list works fine (I have a little more code) but the problem lies with names very similar to each other
If InStr(1, CellText, NameString) Then
In my example above the name "Anne" is part of the name "Tanne" so the list for Tanne will include the expenses for Anne as well. So how do I change the code so that it will find the exact match?
You could write a regex function that looks for the name as a word using word boundary syntax i.e. \bName\b
In my example the arguments to the function equate to CellText, NameString
Try it here.
Option Explicit
Public Sub TEST()
Dim rng As Range
For Each rng In [A1:A4]
If IsNamePresent(rng.Value, "Anne") Then
'do something
End If
Next
End Sub
Public Function IsNamePresent(ByVal inputString As String, testName As String)
IsNamePresent = False
With CreateObject("vbscript.regexp")
.Global = True
.MultiLine = True
.IgnoreCase = False '<== You may want to change this
.Pattern = "\b" & testName & "\b"
If .TEST(inputString) Then IsNamePresent = True
End With
End Function
Test values:
Regex:
\bAnne\b
/
gm
\b assert position at a word boundary (^\w|\w$|\W\w|\w\W)
Anne matches the characters Anne literally (case sensitive)
\b assert position at a word boundary (^\w|\w$|\W\w|\w\W).
So, must be Anne as a word and not Anne as part of a longer string.
one of the possible solutions (the way to achieve required result):
Function getval(searchStr As String, rng As Range) As String
Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")
Dim cl As Range, wrd
For Each cl In rng
For Each wrd In Split(Replace(cl.Value2, ",", ""))
If LCase(wrd) = LCase(searchStr) Then dic.Add cl.Value2, ""
Next wrd, cl
getval = Join(dic.keys, vbNewLine)
End Function
test
Related
I have multiple rows with some words separeted by semicolons(;), and need to count how many times a certain word appears in Column A cell strings of Sheet1.
Using two rows for example:
Column "A"
Banana; Apple; Orange
Banana; Banana; Apple
I came up with this code for the counting of the specific word I want to count:
Sub count()
'The count will be registered in "B6"
strcount = "Banana"
For i = 2 to 30
If InStr(Sheets("Sheet1").Cells(i, "A").Text, strcount) <> 0 Then
Cells(6, "B").Value = Cells(6, "B").Value + 1
End If
Next i
End Sub
The problem with this code is that it doesn't recognize the 2 appearences of "Banana" in the second row returning me a count of 2 instead of 3:
Results for each fruit:
Banana: 2
Apple: 2
Orange: 1
I see that the problem is InStr only recognizes if the string is there, but how can I overcome this?
Solution:
Both basodre's and Алексей's answers worked.
For basodre's code I had to change only the delimiter from ";" to "; " (with a space after the semicolon) to match my string.
aFoods = Split(rIterator.Value, "; ")
Алексей's answer works perfectly too, but by the time of this edit is limited for Excel 2019 or above, given it uses the "TEXTJOIN" function and I couldn't come up with a replacement for that.
Here's an example that I think does what you need. Please review, modify to your range, and let us know if it works.
Sub CountWords()
Dim rng As Range
Dim aFoods As Variant
Dim rIterator As Range
Dim counter As Long
Const theFood As String = "Banana"
Set rng = Range("A1:A3")
counter = 0
For Each rIterator In rng
aFoods = Split(rIterator.Value, ";")
For i = LBound(aFoods) To UBound(aFoods)
If aFoods(i) = theFood Then
counter = counter + 1
End If
Next i
Next rIterator
Debug.Print counter
End Sub
Solution with RegExp:
Option Explicit
Sub test1()
Dim re As Object, result As Object, text As String, fruit As Variant
Set re = CreateObject("vbscript.regexp")
re.Global = True
text = WorksheetFunction.TextJoin(";", True, Columns("A"))
'In Excel < 2019 you can use: text = Join(WorksheetFunction.Transpose(Intersect(Columns("A"), ActiveSheet.UsedRange)), ";")
For Each fruit In Array("Banana", "Apple", "Orange")
re.Pattern = "\b" & fruit & "\b"
Set result = re.Execute(text)
Debug.Print "Amount of [" & fruit & "] = " & result.Count
Next
End Sub
Output:
Amount of [Banana] = 3
Amount of [Apple] = 2
Amount of [Orange] = 1
Using regular expression
Sub FindEntries()
Dim mc, rw
Const word$ = "Banana"
With CreateObject("VBScript.RegExp")
.IgnoreCase = True: .Global = True: .Pattern = "(^|;\s+)" & word & "(?=;|$)"
For rw = 2 To Cells(Rows.Count, "A").End(xlUp).Row
Set mc = .Execute(Cells(rw, "A")): [B6] = [B6] + mc.Count
Next
End With
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
I have sales report from e-shop and need to calculate cost of goods for each order line. Order line can look like one of these:
2x Lavazza Crema e Aroma 1kg - 1x Lavazza Dolce Caffe Crema 1kg
1x Lavazza Vending Aroma Top 1kg - 1x Arcaffe Roma 1Kg - 1x Kimbo - 100% Arabica Top Flavour
So, what I need Excel to do is to take each product, find its cost with vlookup function from another sheet and then multiply it with amount ordered. The issue is that nr of products ordered can vary from 1 to 10+.
I tried to calculate it with VBA, but the code is not working (I didn´t use multiplying at the moment, I know)
Maybe it is possible to solve this problem with excel formulas?
Function GoodsCost(str, Optional strDelim As String = " ")
larray = Split(str, strDelim)
Set lookup_range = Worksheets("Products").Range("B:E")
For i = LBound(larray) To UBound(larray)
skuarray = Split(larray(i), "x ")
skucost = Application.WorksheetFunction.VLookup(UBound(skuarray), lookup_range, 4, False)
cost = cost + skucost
Next i
GoodsCost = cost
End Function
Well, it seems like now the problem is solved. Of course, it works only if make an assumption that dashes(-) are not present in product descriptions. But it can be set up in product list. The other opportunity is to use another delimeter (for example "/"). We can use Ctrl+F to find all combinations like "x -" and replace them with "x /")
Function GoodsCost(str)
Dim answer As Double
Set Products = Worksheets("Products").Range("B:E")
larray = Split(str, " - ")
For i = LBound(larray) To UBound(larray)
sku = Split(larray(i), "x ")
Price = Application.WorksheetFunction.VLookup(sku(1), Products, 4, False) * sku(0)
answer = answer + Price
Next i
GoodsCost = answer
End Function
Below you find a UDF (User Defined Function) which you can use in your worksheet. After installing it in a standard code module (VBE names these like "Module1") you can call it from the worksheet like =CostOfGoods($A2) where A2 is the cell containing and order line as you have described.
Option Explicit
Function CostOfGoods(Cell As Range) As Single
' 15 Jan 2018
Const Delim As String = " - "
Dim Fun As Single ' function return value
Dim Sale As Variant
Dim Sp() As String
Dim i As Long
Dim PriceList As Range
Dim Qty As Single, Price As Single
Dim n As Integer
Sale = Trim(Cell.Value)
If Len(Sale) Then
Sp = Split(Sale, Delim)
Do While i <= UBound(Sp)
If InStr(Sp(i), "x ") = 0 Then
If Not ConcatSale(Sp, i, Delim) Then Exit Do
End If
i = i + 1
Loop
With Worksheets("Products")
i = .Cells(.Rows.Count, "B").End(xlUp).Row
' price list starts in row 2 (change as required)
Set PriceList = Range(.Cells(2, "B"), .Cells(i, "E"))
End With
For i = 0 To UBound(Sp)
Qty = Val(Sp(i))
n = InStr(Sp(i), " ")
Sp(i) = Trim(Mid(Sp(i), n))
On Error Resume Next
Price = Application.VLookup(Sp(i), PriceList, 4, False)
If Err Then
MsgBox "I couldn't find the price for" & vbCr & _
Sp(i) & "." & vbCr & _
"The total cost calculated excludes this item.", _
vbInformation, "Price not found"
Price = 0
End If
Fun = Fun + (Qty * Price)
Next i
End If
CostOfGoods = Fun
End Function
Private Function ConcatSale(Sale() As String, _
i As Long, _
Delim As String) As Boolean
' 15 Jan 2018
Dim Fun As Boolean ' function return value
Dim x As Long, f As Long
x = UBound(Sale)
If (i > 0) And (i <= x) Then
i = i - 1
Sale(i) = Sale(i) & Delim & Sale(i + 1)
For f = i + 1 To x - 1
Sale(f) = Sale(f + 1)
Next f
Fun = True
End If
If Fun Then ReDim Preserve Sale(x - 1)
ConcatSale = Fun
End Function
I have tested this and it works with dashes in product description:
Function GoodsCost(str, Optional strDelim As String = " ")
larray = Split(str, " ")
'split the cell contents by space
Set lookup_range = Worksheets("Products").Range("B:E")
'set lookup range
For i = LBound(larray) To UBound(larray) 'loop through array
nextproduct:
LPosition = InStr(larray(i), "x") 'find multiplier "x" in string
If LPosition = Len(larray(i)) Then 'if the last character is x
If Product <> "" Then GoTo lookitup 'lookup product
Quantity = larray(i) 'get quantity
Else
Product = Product & " " & larray(i) 'concatenate array until we get a full product description to lookup with
End If
Next i
lookitup:
If Right(Product, 2) = " -" Then Product = Left(Product, Len(Product) - 2)
If Left(Product, 1) = " " Then Product = Right(Product, Len(Product) - 1)
'above trim the Product description to remove unwanted spaces or dashes
cost = Application.WorksheetFunction.VLookup(Product, lookup_range, 4, False)
Quantity = Replace(Quantity, "x", "")
GoodsCost = cost * Quantity
MsgBox Product & " # Cost: " & GoodsCost
Product = ""
If i < UBound(larray) Then GoTo nextproduct
End Function
I'd use Regular Expressions to solve this. First it finds in the string were the 'delimiters' are by replacing the - with ; detecting only - that are next to a number followed by an x (i.e. a multiplier so ignoring - in product names). It then splits each of these results into a quantity and the product (again using RegEx). It then finds the product in your data and returns the cost of goods. If there is an error, or the product isn't in your data it returns a #Value error to show that there is an issue.
Public Function GoodsCost(str As String) As Double
Dim lookup_range As Range, ProductMatch As Range
Dim v, Match
Dim qty As Long
Dim prod As String
Dim tmp() As String
On Error GoTo err
Set lookup_range = Worksheets("Products").Range("B:E")
With CreateObject("vbscript.regexp")
.Global = True
.ignorecase = True
.pattern = "(\s\-\s)(?=[0-9]+x)"
If .test(str) Then
tmp = Split(.Replace(str, ";"), ";")
Else
ReDim tmp(0)
tmp(0) = str
End If
.pattern = "(?:([0-9]+)x\s(.+))"
For Each v In tmp
If .test(v) Then
Set Match = .Execute(v)
qty = Match.Item(0).submatches.Item(0)
prod = Trim(Match.Item(0).submatches.Item(1))
Set ProductMatch = lookup_range.Columns(1).Find(prod)
If Not ProductMatch Is Nothing Then
GoodsCost = GoodsCost + (qty * ProductMatch.Offset(0, 3))
Else
GoodsCost = CVErr(xlErrValue)
End If
End If
Next v
End With
Exit Function
err:
GoodsCost = CVErr(xlErrValue)
End Function
Quick question, if I want to delete everything after the second occurrence of a number:
i.e -
I have:
1105 Bracket Ave. Suite 531 Touche
5201 Used St. 1351 Bored Today
I want:
1105 Bracket Ave. Suite 531
5201 Used St. 1351
is there a simple formula or VBA I would use for this?
Here is a UDF using VBA's regular expression engine to remove all after the second integer.
Option Explicit
Function FirstTwoNumbers(S As String) As String
Dim RE As Object
Set RE = CreateObject("vbscript.regexp")
With RE
.Pattern = "(\d+\D+\d+).*"
FirstTwoNumbers = .Replace(S, "$1")
End With
End Function
If there is only a single integer, it will return the entire string.
If the numbers might be decimal numbers, will need to modify .Pattern
And here is another UDF using only native VBA methods:
Function FirstTwo(S As String) As String
Dim V
Dim tS As String
Dim I As Long, numNumbers As Long
V = Split(S)
Do Until numNumbers = 2
tS = tS & Space(1) & V(I)
I = I + 1
If IsNumeric(V(I - 1)) Then numNumbers = numNumbers + 1
Loop
FirstTwo = Mid(tS, 2)
End Function
and finally, a formula with no particular assumptions:
=LEFT(A1,FIND(CHAR(1),SUBSTITUTE(A1," ",CHAR(1),LOOKUP(2,1/ISNUMBER(-TRIM(MID(SUBSTITUTE(A1," ",REPT(" ",99)),seq_99,99))),seq))))
seq and seq99 are Named Formulas Formula ► Define Name
seq Refers to: =ROW(INDEX($1:$255,1,1):INDEX($1:$255,255,1))
seq_99 Refers to: =IF(ROW(INDEX($1:$255,1,1):INDEX($1:$255,255,1))=1,1,(ROW(INDEX($1:$255,1,1):INDEX($1:$255,255,1))-1)*99)
This solution is with these assumptions:-
First occurrence of a number will not have a length > 10
There will atleast a distance of 10 or 10 alphabets including spaces between first and second number
There will always be a 'space' existing after second number
There will always be a second number present in the string
Try this:-
=TRIM(MID(A1,1,FIND(" ",A1,MIN(FIND({0,1,2,3,4,5,6,7,8,9},A1&"0123456789",MIN(FIND({0,1,2,3,4,5,6,7,8,9},A1&"0123456789"))+10)))))
Here is a VBA approach, amend range to suit. It puts the answer in the adjacent column
Sub x()
Dim oMatches As Object, r As Range
With CreateObject("VBScript.RegExp")
.Global = True
.Pattern = "\d+"
For Each r In Range("A1:A5")
If .Test(r) Then
Set oMatches = .Execute(r)
If oMatches.Count > 1 Then
r.Offset(, 1).Value = Left(r, oMatches(1).firstindex + oMatches(1).Length)
Else
r.Offset(, 1).Value = r.Value
End If
Else
r.Offset(, 1).Value = r.Value
End If
Next r
End With
End Sub
You can use the following formula,if A1 is your string,in B1 write:
=LEFT(A1,MAX(IFERROR(ISNUMBER(VALUE(MID(A1,ROW(INDIRECT("1:"&LEN(A1))),1)))*ROW(INDIRECT("1:"&LEN(A1))),0)))
press Ctrl+Shift+Enter at the same time Array Formula
This will read the length of the string and return the Maximum place of numbers (last number in the string) and return the Left() string till this number
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.