I'm trying to delete string content up to a certain word contained within the string. For example
"Emily has wild flowers. They are red and blue."
I'd like to use VBA in order to replace that with
"They are red and blue."
i.e. remove all the content up to the word "They". I don't know the string content and the number of characters contained in it.
I'm not sure how to do this and I'd really appreciate your help!
Here you go:
Dim s As String
s = "Emily has wild flowers. They are red and blue."
Dim indexOfThey As Integer
indexOfThey = InStr(1, s, "They")
Dim finalString As String
finalString = Right(s, Len(s) - indexOfThey + 1)
Simple example of dropping all text before value in string.
Sub Foo()
Dim strOrig As String
Dim strReplace As String
strOrig = "The Quick brown fox jumped over the lazy dogs"
strReplace = "jumped"
MsgBox (DropTextBefore(strOrig, strReplace))
End Sub
Public Function DropTextBefore(strOrigin As String, strFind As String)
Dim strOut As String
Dim intFindPosition As Integer
'case insensitive search
'could made it so that case sensitivity is a parameter but this gets the idea across.
If strOrigin <> "" And strFind <> "" Then
intFindPosition = InStr(UCase(strOrigin), UCase(strFind))
strOut = Right(strOrigin, Len(strOrigin) - (intFindPosition + Len(strFind) - 1))
Else
strOut = "Error Empty Parameter in function call was encountered."
End If
DropTextBefore = strOut
End Function
If the word is fixed, like "They" in the above example, you can simply do
CTRL + H (Replace)
*They (your word with a star)
in the Find box. The star * is a wildcard character which can be called as - of anything before or after (if added at end) the word.
Cautious: Take care when you have duplicate words in the same cell.
This worked great for me:
Sub remove_until()
Dim i, lrowA, remChar As Long
Dim mString As String
lrowA = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To lrowA
mString = Cells(i, 1).Value
If InStr(mString, "They") > 0 Then
remChar = Len(mString) - InStr(mString, "They") + 1
Cells(i, 2).Value = Left(mString, Len(mString) - remChar)
End If
Next
End Sub
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 have a rather tricky problem. I am trying to split and declare a different parts of a string for further use. Obviously there I have a different delimiters to do that.
Say I wanted to split a standard screw code: DIN912M6x10A2 into it's different parts since each part of that code means specific something.
ScreHead is Left up to first "M" without the delimiter = DIN912
ScrewThickness is "M" included up to "x" excluded = M5
ScrewLenght is "x" excluded up to "A" excluded = 10
ScrewMaterial is "A" included up to the " " or if there's no " " then up to the end of the string = A2
What I have so far codewise is (I am working in 5th column):
Dim ScrewHead As Long
ScrewHead = Split(Cells(i, 5), "M"-1)
Dim ScrewDiameter As Long
ScrewDiameter =Split(i,5),"M", "x"-1)
Dim ScrewLenght As Long
ScrewLenght =Split(i,5),"x"-1, "A"-1)
Dim ScrewMaterial As Long
ScrewMaterial =Split(i,5),"A", " ")
Could someone help me with figuring this one out?
Sounds like a nice job for a regular expression to be honest when you can capture all the parts in their own groups. For example through:
^(.+?)(M\d+)x(\d+)(.+?)(?:\s.*)?$
See the online demo
^ - Start line anchor.
(.+?) - A 1st capture group holding 1+ (lazy) characters upto;
(M\d+) - 2nd Capture group with a literal "M" followed by 1+ (greedy) digits.
x - A literal "x".
(\d+) - A 3rd capture group holding 1+ (greedy) digits.
(.+?) - A 4th capture group holding 1+ (lazy) characters upto;
(?:\s.*)? - An optional non-capture group of a space character with 0+ (greedy) characters.
$ - End line anchor.
Here is a quick code to run to retrieve these groups:
Sub Test()
Dim str As String: str = "DIN912M6x10A2 test"
With CreateObject("vbscript.regexp")
.Global = True
.Pattern = "^(.+?)(M\d+)x(\d+)(.+?)(?:\s.*)?$"
If .Test(str) = True Then
For Each Match In .Execute(str)(0).Submatches
Debug.Print Match
Next
End If
End With
End Sub
A more extensive code-example for a better understanding:
Sub Test()
Dim str As String: str = "DIN912M6x10A2 test"
Dim ScrewHead As String, ScrewDiameter As String, ScrewLenght As Long, ScrewMaterial As String
Dim matches
With CreateObject("vbscript.regexp")
.Global = True
.Pattern = "^(.+?)(M\d+)x(\d+)(.+?)(?:\s.*)?$"
If .Test(str) = True Then
Set matches = .Execute(str)
ScrewHead = matches(0).Submatches(0)
ScrewDiameter = matches(0).Submatches(1)
ScrewLenght = matches(0).Submatches(2)
ScrewMaterial = matches(0).Submatches(3)
End If
End With
End Sub
Here's a plain VBA based sledgehammer approach. You can adopt the code to suit your requirements.
Public Sub GetDiffPartsofString()
Dim strInput As String, strScrewHead As String, strScrewThck As String, strScrewLeng As String, strScrewMatl As String
Dim i As Long, j As Long
strInput = "DIN912M6x10A2"
j = 1
For i = 1 To Len(strInput)
Select Case Mid(strInput, i, 1)
Case "M"
strScrewHead = Mid(strInput, j, i - 1)
j = i
Case "x"
strScrewThck = Mid(strInput, j, i - j)
j = i
Case "A"
strScrewLeng = Mid(strInput, j + 1, i - j - 1)
strScrewMatl = Mid(strInput, i, Len(strInput))
End Select
Next i
Debug.Print strScrewHead, strScrewThck, strScrewLeng, strScrewMatl
End Sub
Tricky split approach via Val()
Another way leading to Rome:
Sub AnalyzeID()
Dim s As String: s = "DIN912M6x10A2 test"
Dim parts: parts = Split(Replace(Replace(s, "M", "x"), " ", "x"), "x")
'adjust split elements
parts(1) = "M" & parts(1)
parts(3) = Split(parts(2), Val(parts(2)))(1) ' (don't change code line order!)
parts(2) = Val(parts(2))
Debug.Print Join(parts, "|") ' ~~> DIN912|M6|10|A2
End Sub
Output in VB Editor's immediate window
DIN912|M6|10|A2
Example
Say I have a string:
"I say ""Hello world"" and she says ""Excuse me?"""
VBA will interpret this string as:
I say "Hello world" and she says "Excuse me?"
A more complex example:
I have a string:
"I say ""Did you know that she said """"Hi there!"""""""
VBA interprets this string as:
I say "Did you know that she said ""Hi there!"""
If we remove "I say "
"Did you know that she said ""Hi there!"""
we can continue parsing the string in vba:
Did you know that she said "Hi there!"
Problem
Ultimately I want some function, sBasicQuote(quotedStringHierarchy as string), which returns a string containing the next level up in the string hierarchy.
E.G.
dim s as string
s = "I say ""Did you know that she said """"Hi there!"""""""
s = sBasicQuote(s) ' returns 'I say "Did you know that she said ""Hi there!"""'
s = sBasicQuote(s) ' returns 'Did you know that she said "Hi there!"'
s = sBasicQuote(s) ' returns 'Hi there!'
I just can't figure out an algorithm that would work with this... You almost need to replace all double quotes, but when you've replaced the nth double quote you have to skip to the n+1th douple quote?
How does one implement this in VBA?
You could do something like this
Public Sub test()
Dim s As String
s = "I say ""Did you know that she said """"Hi there!"""""""
Debug.Print DoubleQuote(s, 0)
Debug.Print DoubleQuote(s, 1)
Debug.Print DoubleQuote(s, 2)
End Sub
Public Function DoubleQuote(strInput As String, intElement As Integer) As String
Dim a() As String
strInput = Replace(strInput, String(2, Chr(34)), String(1, Chr(34)))
a = Split(strInput, chr(34))
DoubleQuote = a(intElement)
End Function
Another slightly modified version is a little more accurate
`Public Function DoubleQuote(strInput As String, intElement As Integer) As String
Dim a() As String
Dim b() As String
Dim i As Integer
ReDim b(0)
a = Split(strInput, Chr(34))
' ***** See comments re using -1 *******
For i = 0 To UBound(a) - 1
If Len(a(i)) = 0 Then
b(UBound(b)) = Chr(34) & a(i + 1) & Chr(34)
i = i + 1
Else
b(UBound(b)) = a(i)
End If
ReDim Preserve b(UBound(b) + 1)
Next i
DoubleQuote = b(intElement)
End Function`
I think the following will return what you are looking for in your nested quote example. Your first example is not really a situation of nested quotes.
Option Explicit
Sub NestedQuotes()
Const s As String = "I say ""Did you know that she said """"Hi there!"""""""
Dim COL As Collection
Dim Start As Long, Length As Long, sTemp As String, V As Variant
Set COL = New Collection
sTemp = s
COL.Add sTemp
Do Until InStr(sTemp, Chr(34)) = 0
sTemp = COL(COL.Count)
sTemp = Replace(sTemp, String(2, Chr(34)), String(1, Chr(34)))
Start = InStr(sTemp, Chr(34)) + 1
Length = InStrRev(sTemp, Chr(34)) - Start
sTemp = Mid(sTemp, Start, Length)
COL.Add sTemp
Loop
For Each V In COL
Debug.Print V
Next V
End Sub
My Solution
I spent some more time thinking and came up with this solution.
Function sMineDoubleQuoteHierarchy(s As String) As String
'Check the number of quotes in the string are even - sanity check
If (Len(s) - Len(Replace(s, """", ""))) Mod 2 <> 0 Then sMineDoubleQuoteHierarchy = "Error - Odd number of quotes found in sMineDoubleQuoteHierarchy() function": Exit Function
'First thing to do is find the first and last *single* quote in the string
Dim lStart, lEnd, i As Long, fs As String
lStart = InStr(1, s, """")
lEnd = InStrRev(s, """")
'After these have been found we need to remove them.
s = Mid(s, lStart + 1, lEnd - lStart - 1)
'Start at the first character
i = 1
Do While True
'Find where the next double quote is
i = InStr(1, s, """""")
'if no double quote is found then concatenate with fs with the remainder of s
If i = 0 Then Exit Do
'Else add on the string up to the char before the ith quote
fs = fs & Left(s, i - 1)
'Replace the ith double quote with a single quote
s = Left(s, i - 1) & Replace(s, """""", """", i, 1)
'Increment by 1 (ensuring the recently converted double quote is no longer a single quote
i = i + 1
Loop
'Return fs
sMineDoubleQuoteHierarchy = s
End Function
What's going on in this solution?
The first part of the process is removing the first and last single quote from the string and returning the text between them. Then we loop through the string replacing each instance of "" and replacing it with ". Each time we do this we skip to the next character to unsure strings like """" go to "" instead of ".
Does anyone else have a better/more compact solution?
Edit
After all the suggestions in this forum I settled with this. It's got some extra error trapping to find validate nested strings.
Public Function DoubleQuoteExtract(ByVal s As String, Optional ByRef ErrorLevel As Boolean) As String
'This effectively parses the string like BASIC does by removing incidents of "" and replacing them with "
'SANITY CHECK - Check even number of quotes
Dim countQuote As Double
countQuote = Len(s) - Len(Replace(s, """", ""))
'Calculate whether or not quote hierarchy is correct:
'"..." - Is okay - Count Quotes = 2 - Count Quotes / 2 = 1
'""..."" - Is not okay - Count Quotes = 4 - Count Quotes / 2 = 2
'"""...""" - Is okay - Count Quotes = 6 - Count Quotes / 2 = 3
'""""..."""" - Is not okay - Count Quotes = 8 - Count Quotes / 2 = 4
'etc.
'Ultimately: IF CountQuotes/2 = Odd The string hierarchy is setup fine
' IF CountQuotes/2 = Even, The string Hierarchy is setup incorrectly.
Dim X As Double: X = countQuote / 2
Dim ceil As Long: ceil = Int(X) - (X - Int(X) > 0)
If ceil Mod 2 <> 0 Then sDoubleQuoteExtract = "#Error - Incorrect number of double quotes forming an incomplete hierarchy.": GoTo ErrorOccurred
'If an odd number of quotes are found then they cannot be paired correctly, thus throw error
If countQuote Mod 2 <> 0 Then sDoubleQuoteExtract = "#Error - Odd number of quotes found in sMineDoubleQuoteHierarchy() function": GoTo ErrorOccurred
'Find the next incident of single quote. Trim the string to this
s = Mid(s, InStr(1, s, String(1, Chr(34))))
'replace all instances of "" with "
s = Replace(s, String(2, Chr(34)), String(1, Chr(34)))
'Finally trim off the first and last quotes
DoubleQuoteExtract = Mid(s, 2, Len(s) - 2)
ErrorLevel = False
Exit Function
ErrorOccurred:
ErrorLevel = True
End Function
Using VBA or A Standard formula, I need to edit the following from cells.
I need to remove everything up to and including "Path:",
Then I need it to find | and start over until it reaches the end of the Cell
Example:
Category Name: Ladies, Category Path: Ladies|Category Name: Sale, Category Path: Sale|Category Name: New, Category Path: New|
Goal:
Ladies|Sale|New
It can include NO "|" or it can include up to 20 "|"
Edit: Realized I needed to show my work AFTER the tour. :)
I have spent a day or two on this and so far this is only I can come up with...
Dim s As String
s = Range("Z7").Value
Dim indexOfPath As Integer
Dim indexOfPipe As Integer
Dim indexOfCat As Integer
indexOfPath = InStr(1, s, "Path:")
indexOfPipe = InStr(1, s, "|")
Dim finalString As String
Dim pipeString As String
finalString = Right(s, Len(s) - indexOfPath - 5)
indexOfCat = InStr(1, finalString, "Path:")
pipeString = Right(finalString, Len(finalString) - indexOfCat - 5)
Range("A47").Value = finalString
Range("A48").Value = pipeString
How ever I have got to the point where I am not confusing myself...
Split the cell value on "|", then split each value in the resulting array on "Path:" and take the second element from the result of that.
Like this:
Sub Tester()
Dim s As String, arr, v, arr2
s = "Category Name: Ladies, Category Path: Ladies|Category Name:" & _
" Sale, Category Path: Sale|Category Name: New, Category Path: New|"
arr = Split(s, "|")
For Each v In arr
v = Trim(v)
If Len(v) > 0 Then
arr2 = Split(v, "Path:")
If UBound(arr2) > 0 Then Debug.Print arr2(1)
End If
Next v
End Sub
Try this Function:
Function splitonbar(rng As Range) As String
Dim tempArr() As String
Dim temp As String
Dim i As Integer
tempArr = Split(rng.Value, "|")
For i = LBound(tempArr) To UBound(tempArr)
If Len(tempArr(i)) > 0 Then
temp = temp & "|" & Trim(Mid(tempArr(i), InStr(tempArr(i), "Path:") + 5))
End If
Next i
splitonbar = Mid(temp, 2)
End Function
It can be used as Formula on the sheet, or be called from another sub. To use as a UDF put in a module in the workbook then simply call it with a formula:
=splitonbar(Z7)
Or you can call it with a sub like this:
Sub splitstring()
Dim t as string
t = splitonbar(range("Z7"))
debug.print t
end sub
To directly fit your needs:
Public Function test(ByVal arg As Variant) As String
Dim i As Long
arg = Split(arg, "Category Name: ")
For i = 1 To UBound(arg)
arg(i) = Left(arg(i), InStr(arg(i), ",") - 1)
Next
test = Mid(Join(arg, "|"), 2)
End Function
The Split itself cuts everything in front of the keyword. The Left cuts everything after the comma (including the comma itself)
If you still have questons left, just ask :)
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.