Copy clipboard data to array - excel

I have to to copy text, from a web page using Ctrl A + Ctrl C, to use in Excel.
The copied text is about 100 lines with different sizes. Let us say one line has a string of 200 characters and the next one has 500 characters and the third maybe 20 characters.
Is there a way to loop over the clipboard data lines and copy them to an array?
Sample of the copied text (made with Ctrl A Ctrl C in the page):
Note : I removed some Lines
Usernames are XXXXXXXXXXXXXXXXX
DashboardAnalyticsPolicyAdministration
Web Insights
Print View
Start Over
1Select Chart Type
Logs
Apply Filters
2Choose a Timeframe
Custom: 9/1/2015 12:00:00 AM - 9/30/2015 12:00:00 AM
3Select Filters
Add Filter
2.4 TB
2.0 TB
879.9 GB
656.8 GB
472.0 GB
442.4 GB
242.1 GB
213.5 GB
189.3 GB
103.8 GB
Office 365 - SSL Bypass
Professional Services
Streaming Media
Sites everyone
Internet Services
Corporate Marketing
Miscellaneous
Web Search
News and Media
Social Networking
URL CategoryTop 10TransactionsBytes

To follow up on my comment, if you follow the instructions from here add a reference to Microsoft Forms Library 2.0 (under Tools/References in the VBA editor), the following function takes the contents of the clipboard and splits it into lines:
Function ClipToArray() As Variant
Dim clip As New MSForms.DataObject
Dim lines As String
clip.GetFromClipboard
lines = clip.GetText
lines = Replace(lines, vbCr, "")
ClipToArray = Split(lines, vbLf)
End Function
You can test it like this:
Sub test()
Dim A As Variant
Dim i As Long
A = ClipToArray()
For i = LBound(A) To UBound(A)
Debug.Print A(i)
Next i
End Sub
Then I went to this website and copied the poem and then ran test. I got the following output in the immediate window:
Some say the world will end in fire,
Some say in ice.
From what I've tasted of desire
I hold with those who favor fire.
But if it had to perish twice,
I think I know enough of hate
To say that for destruction ice
Is also great
And would suffice.
This worked nicely enough, although you don't have to run many experiments with text copied from the internet before you see that the superficial parsing using split leaves much to be desired.

I made this for those who want to extract 2D information from a copied range.
'Display the content of the clipboard
Sub test()
Dim A As Variant
Dim i As Long
A = ClipToArray()
For i = LBound(A, 1) To UBound(A, 1)
tmp = ""
For j = LBound(A, 2) To UBound(A, 2)
tmp = tmp & A(i, j) & " | "
Next
Debug.Print tmp
Next
End Sub
'Made by LePatay on 2018/12/07
'Extract a 2D array from a copied 2D range
Function ClipToArray()
'Include Tools -> References -> Microsoft Forms 2.0 Object Library
'or you will get a "Compile error: user-defined type not defined"
Dim dataobj As New MSForms.DataObject
Dim array2Dfitted As Variant
Dim cbString As String
'Special characters
quote = """"
tabkey = vbTab
CarrReturn = vbCr
LineFeed = vbLf
'Get the string stored in the clipboard
dataobj.GetFromClipboard
On Error GoTo TheEnd
cbString = dataobj.GetText
On Error GoTo 0
'Note: inside a cell, you only find "vbLf";
'at the end of each row, you find "vbCrLf", which is actually "vbCr & vbLf".
cbString = Replace(cbString, vbCrLf, CarrReturn)
'Length of the string
nbChar = Len(cbString)
'Get the number of rows
nbRows = Application.Max(1, nbChar - Len(Replace(cbString, CarrReturn, "")))
'Get the maximum number of columns possible
nbColumnsMax = nbChar - Len(Replace(cbString, tabkey, "")) + 1
'Initialise a 2D array
Dim array2D As Variant
ReDim array2D(1 To nbRows, 1 To nbColumnsMax)
'Initial position in array2D (1st cell)
curRow = 1
curColumn = 1
'Initialise the actual number of columns
nbColumns = curColumn
'Initialise the previous character
prevChar = ""
'Browse the string
For i = 1 To nbChar
'Boolean "copy the character"
bCopy = True
'Boolean "reinitialise the previous character"
bResetPrev = False
'For each character
curChar = Mid(cbString, i, 1)
Select Case curChar
'If it's a quote
Case quote:
'If the previous character is a quote
If prevChar = quote Then
'Indicates that the previous character must be reinitialised
'(in case of a succession of quotes)
bResetPrev = True
Else
'Indicates the character must not be copied
bCopy = False
End If
'If it's a tab
Case tabkey:
'Indicates the character must not be copied
bCopy = False
'Skip to the next column
curColumn = curColumn + 1
'Updates the actual number of columns
nbColumns = Application.Max(curColumn, nbColumns)
'If it's a carriage return
Case CarrReturn:
'Indicates the character must not be copied
bCopy = False
'If it's not the 1st character
If i > 1 Then
'Skip to the next row
curRow = curRow + 1
curColumn = 1
End If
End Select
'If the character must be copied
If bCopy Then
'Adds the character to the current cell
array2D(curRow, curColumn) = array2D(curRow, curColumn) & curChar
End If
'If the previous character must be reinitialised
If bResetPrev Then
prevChar = ""
Else
'Saves the character
prevChar = curChar
End If
Next
'Create a 2D array with the correct dimensions
ReDim array2Dfitted(1 To nbRows, 1 To nbColumns)
'Copies the data from the big array to the fitted one (no useless columns)
For r = 1 To nbRows
For c = 1 To nbColumns
array2Dfitted(r, c) = array2D(r, c)
Next
Next
TheEnd:
ClipToArray = array2Dfitted
End Function
Remarks:
There is no way to tell if cells are merged).
This code is robust to quotes, successions of quotes, and multiple lines inside a cell.
It has been tested on a French Excel, Win 7 64 bit. The system of quotes / carriage returns / line feeds may differ on your OS.

Related

VBA how to find entire number in a string and set to variable

I have a list that was copied from a 'table of contents' page to column D. Unfortunately, each cell contains the chapter number, chapter name, and the page number.
3.14.4 chapter name placeholder.140
Sometimes there is a space between the page number and the last character. other times there is not.
I've tried
Function john(txt As String) As Long
Dim x
x = Split(Trim(txt), Chr(32))
john = Val(x(UBound(x)))
End Function
Which does work but I'd like to be able to apply this to the chapter number as well afterwards.
Private Sub FIND_LAST_NUMBER()
Dim A As String
Dim B As Integer
Dim C As String
Dim D As String
x = 3
Do While ActiveSheet.Cells(x, 4).Value <> ""
A = Range("D" & x).Value
A = Trim(A)
B = Len(A)
For Position = B To 1 Step -1
C = Mid(A, Position, 1)
'MsgBox C
If C <> " " Then
D = Right(A, B - Position)
Range("E" & x).Value = C
GoTo LastLine
'Exit Sub
End If
Next Position
LastLine:
x = x + 1
Loop
End Sub
but I'm trying to figure out how to get all of the number instead of only the last digit of the page number from the original cell
I am obviously not getting something here.
Any tips or tricks will be greatly appreciated
One, admittedly not very beautiful solution I can think of right away would be to use Replace to remove all non-numeric characters.
Dim str As String
str = Replace(str, " ", "") '<- to remove the random spaces
str = LCase(str) '<- making everything lower case
For i = 97 To 122
str = Replace(str, Chr(i), "")
Next i
Chr(i) with i from 97 to 122 will be every Character of the standard Alphabet.
This does not work if special Characters appear in the Chapter Name String. If the Chapter name contains numbers these will remain, but you could detect that case because UBound of the split array will be 1 greater than usual.
Also if you can quickly scan all the cells with your data for other unwanted Characters like - / or whatever might occur, you can also get rid of them with Replace
Performance of this solution might not be great but for a quick fix it might do..

Macro to split text string into their own columns - no fixed length/delimiter

I need help figuring out an easy way (preferably a macro) to split data entered in 1 cell (separated by spaces - lengths are not fixed) into their own columns. I have about 100k entries to work with.
I am currently doing this using a combination of Left, Right, Find functions but it's taking me forever.
Sample data layout (All in Column A): http://prntscr.com/32l81u
I'm looking for a way to split each line into columns based on their entries. The only piece of information with fixed length is the first entry for each set which is 9 characters long. I need all the entries in each set to be their own columns. Each set is separated by the series of --- and |
Any help would be much appreciated.
Thank you!
Your example source data contains four different formats. You may believe there are only four formats but my experience of such tasks is that you will find another format starting on row 312 then another on row 1543 and so on.
You have to code the first version of the macro for the data you expect to find but you must check the data conforms to your expectations. If a set fails to conform to expectations, amend the macro to handle this new format as well as previous formats and try the macro again. It may take many versions before the macro can successfully decode an entire source worksheet.
The code below contains comments to tell what it is doing but here I will explain my approach.
The code contains a great many statements of the form: Debug.Assert boolean-expression. These statements check my assumptions and the code will stop if the expression returns False. I have made no attempt to carry on if an assumption is false. It would be possible to skip to the next set and carry on to find more faulty assumptions but I have always found it easiest to fix one problem at a time.
I process the contents of the sets as a list of tokens which I expect to appears in a a small number of fixed sequences. I define a token as something separated from its neighbour by two or more spaces. I have a routine GetTokenArray which moves the complexity of splitting the cell values into its own routine. If my definition of a token is faulty then this is the routine that will need to be rewritten.
Please note: a token does not necessary match a column. If my understanding of the source data is correct, the first token of a set will be something like: "aaaaaaaaa Doe, John". This will have to be divided into two.
In examples 1 and 2, the second line starts MM/DD/YY City, St ZCode while in examples 3 and 4 it starts MM/DD/YY LName, FNam MName. It would take some clever code to reliably distinguish addresses from names if you have to allow for non-American addresses. Example 3 and 4 have MM/DD/YY City, St ZCode as the start of line 4. Unless there is some fixed difference between these two formats that a macro can identify, you have a serious problem.
One of my reasons for getting an entire set as an array is that it allows the macro to look ahead easily if this would help to identify the format of the set.
I hope the code below gets you started.
Option Explicit
Sub CtrlDecode()
Dim InxTA As Long
Dim RowOutCrnt As Long
Dim RowSrcCrnt As Long
Dim RowSrcLast As Long
Dim TokenPart() As String
Dim SrcData As Variant
Dim TokenArray() As String
' It might be possible to place output column values directly into a cell
' or into an array for writing to an output row. However, it seems to me
' that it will be easier to place column values into specific variables
' as the set is processed and then move them when processing has finished.
' No doubt you will want to replace my variable names with something more
' appropriate.
Dim Id1 As String ' Leading nine character identifier
Dim Name As String
Dim Id2 As String ' XX/XXX/XXXXX
Dim Id3 As String ' XXX/xx
' This macro outputs decoded data to worksheet "Output".
' Change as necessary.
With Worksheets("Output")
' Delete all data created by previous run of macro.
.Cells.EntireRow.Delete
' Set column widths
.Columns("A").ColumnWidth = 11#
.Columns("B").ColumnWidth = 25#
.Columns("C").ColumnWidth = 12#
.Columns("D").ColumnWidth = 7.14
End With
' This macro reads source data from worksheet "Source".
' Change as necessary.
With Worksheets("Source")
' Find last row containing data
RowSrcLast = .Cells(Rows.Count, 1).End(xlUp).Row
' Load all data into an array. I believe this will be more convenient
' that accessing the data cell by cell and it will be faster.
SrcData = .Range(.Cells(1, 1), .Cells(RowSrcLast, 1)).Value
End With
RowSrcCrnt = 1
RowOutCrnt = 1
Do While RowSrcCrnt <= RowSrcLast
' Record start row of current set for error message
Call GetTokenArray(SrcData, RowSrcCrnt, TokenArray)
' First token.
' Expect 9-character-id space FName comma space LName
TokenPart = Split(TokenArray(1), " ")
' Expect three parts: first with length of 9, second ending
' in comma.
Debug.Assert UBound(TokenPart) = 2
Debug.Assert Len(TokenPart(0)) = 9
Debug.Assert Right(TokenPart(1), 1) = ","
Id1 = TokenPart(0)
Name = TokenPart(1) & " " & TokenPart(2)
' Second token.
' Expect xx/xxx/xxxxx
TokenPart = Split(TokenArray(2), "/")
Debug.Assert UBound(TokenPart) = 2
Debug.Assert Len(TokenPart(0)) = 2
Debug.Assert Len(TokenPart(1)) = 3
Debug.Assert Len(TokenPart(2)) = 5
Id2 = TokenArray(2)
' Third token.
' Expect xxx/xx
TokenPart = Split(TokenArray(3), "/")
Debug.Assert UBound(TokenPart) = 1
Debug.Assert Len(TokenPart(0)) = 3
Debug.Assert Len(TokenPart(1)) = 2
Id3 = TokenArray(3)
' Continue with remaining tokens. The next few tokens appears to be
' the same in all formats so you could continue accessing TokenArray(4),
' TokenArray(5) and so on as I have. It then looks as though the tokens
' present vary from format to format. You will then have to use a
' variable, such as InxTA, and have code like:
' If TokenArray(InxTA) is optional token xyz Then
' VariableXyz = TokenArray(InxTA)
' InxTA = InxTA + 1
' Else
' VariableXyz = ""
' End If
' There are a variety of ways of transferring values to the output
' worksheet. I suspect a cell by cell write is the easiest although
' not the fastest.
With Worksheets("Output")
.Cells(RowOutCrnt, "A").Value = Id1
.Cells(RowOutCrnt, "B").Value = Name
.Cells(RowOutCrnt, "C").Value = Id2
.Cells(RowOutCrnt, "D").Value = Id3
RowOutCrnt = RowOutCrnt + 1
End With
Loop
End Sub
Sub GetTokenArray(SrcData As Variant, RowSrcCrnt As Long, TokenArray() As String)
' * SrcData(1 To X, 1 To 1) contains all the data from the source worksheet
' * On entry, RowSrcrnt points at the first row of a set. On exit, it points
' at the first row of the next set.
' * On exit, TokenArray will dimensioned as (1 To N) where N is the number of
' tokens found. Each entry will contain one token in the sequence found.
' * A set is ended by a row starting "-----" and containing nothing but
' hyphens and pipes.
' * A token is separated from its neighbour by two or more spaces.
Debug.Assert RowSrcCrnt < UBound(SrcData, 1) ' SrcData already processed
' The upper bound of 500 is intended to be more than could possibly be
' required so as not to bother with enlarginging a small array when it
' becomes full.
ReDim TokenArray(1 To 500)
Dim DataCrnt As String
Dim InxTA As Long
Dim PosCrnt As Long
Dim Pos2Spaces As Long
InxTA = 0
Do While True
DataCrnt = SrcData(RowSrcCrnt, 1)
Debug.Assert DataCrnt <> "" ' Unexpected empty row
' Check for row being end of set
If Left(DataCrnt, 5) = "-----" And _
Replace(Replace(DataCrnt, "-", ""), "|", "") = "" Then
' End of set
Exit Do
End If
' Extract all token from current row
PosCrnt = 1
Do While True
Do While True
' Search for non-space
If PosCrnt > Len(DataCrnt) Then
' End of cell value
Exit Do
End If
If Mid(DataCrnt, PosCrnt, 1) <> " " Then
' Start of next token found
Exit Do
End If
PosCrnt = PosCrnt + 1
Loop ' until end of cell or next token
If PosCrnt > Len(DataCrnt) Then
' This cell finished
RowSrcCrnt = RowSrcCrnt + 1
Debug.Assert RowSrcCrnt < UBound(SrcData) ' Last set not terminated
Exit Do
Else
' Have found first character of next token
Pos2Spaces = InStr(PosCrnt, DataCrnt, " ")
If Pos2Spaces = 0 Then
' Everything up to end of cell is last token of cell
InxTA = InxTA + 1
' Trim to remove trailing single space
TokenArray(InxTA) = Trim(Mid(DataCrnt, PosCrnt))
' This cell finished
RowSrcCrnt = RowSrcCrnt + 1
Debug.Assert RowSrcCrnt <= UBound(SrcData) ' Last set not terminated
Exit Do
Else
' Everything up to 2 spaces is next token of this cell
InxTA = InxTA + 1
TokenArray(InxTA) = Mid(DataCrnt, PosCrnt, Pos2Spaces - PosCrnt)
PosCrnt = Pos2Spaces + 2
End If
End If
Loop ' until end of cell
Loop ' until end of set
Debug.Assert InxTA > 0 ' Empty set
' Discard unused entries
ReDim Preserve TokenArray(1 To InxTA)
RowSrcCrnt = RowSrcCrnt + 1 ' Step over dividing row
End Sub
Give this a try:
Sub parser()
Dim N As Long, wf As WorksheetFunction
Set wf = Application.WorksheetFunction
N = Cells(Rows.Count, "A").End(xlUp).Row
Dim i As Long, j As Long, k As Long
For i = 1 To N
ary = Split(wf.Trim(Cells(i, "A").Text), " ")
k = 2
For j = LBound(ary) To UBound(ary)
Cells(i, k).Value = ary(j)
k = k + 1
Next j
Next i
End Sub

Searching a string for numbers including decimals in VBA

So I'm working on a project that has inputs from a fairly clunky database that I have zero control over what type of data it gives me. It basically gives me a string that has numbers in it including decimals.
"take 0.5 Tab by mouth 2 times daily."
Whenever it says tab I want to grab the number before tab and convert it to double format. I know how to use cdbl to convert it once I have the string "0.5" but how I get just that string is kind of difficult since InStr only searches left to right. My thought was to use InStr to find the space before the number that comes before the word "tab" but I'm having trouble figuring out how to code it. Any suggestions?
InStrRev searches right to left. Alternatively, you can use StrReverse and work with the output, but I would use VBScript.Regexp:
Dim text As String
text = "take 0.5 Tab by mouth 2 times daily"
Dim regex As Object
Set regex = CreateObject("VBScript.Regexp")
regex.Global = True
regex.Pattern = "[\d\.]+(?=\sTab)"
Dim test As Object
Set test = regex.Execute(text)
MsgBox (test(0).Value)
Update using Tab as relevant indicator
Assuming that Tab is the relevant indicator you could do the follwing:
Sub ExtractElement()
' column 4 and row 6 contains the text "take 0.5 Tab by mouth 2 times daily"
s = Cells(6, 4).Value
' split text into array for each space
sAr = Split(s, " ")
' iterate over each element of array
For i = 0 To UBound(sAr) - 1
' if the array element "Tab" is reached
If sAr(i) = "Tab" Then
' write the previous array element into the next column
Cells(6, 5).Value = sAr(i-1)
End If
Next
End Sub
Beware that each word is really seperated by a " ". I copied your text and noticed that "Tab by" was not seperated.
Sub ExtractCharCode()
s = Cells(7, 4).Value
For i = 1 To Len(s)
Cells(i, 8).Value = Mid(s, i, 1)
Cells(i, 9).Value = Asc(Mid(s, i, 1))
Next
End Sub
Update using a variation of the answer from user matzone
Instead of passing a range into the function from matzone i would only pass the Value and add a trim to it
Public Function TakeBeforeTab2(s As String) As String
s = Mid(s, 1, InStr(UCase(s), "TAB") - 1)
TakeBeforeTab2 = Trim(Mid(s, InStr(s, " ") + 1))
End Function
To get "0.5" from "take 0.5 Tab by mouth 2 times daily."
Public Function TakeBeforeTab(r As Range) As String
Dim s As String
s = r.Value
s = Mid(s, 1, InStr(UCase(s), "TAB") - 2)
TakeBeforeTab = Mid(s, InStr(s, " ") + 1)
End Function

Split and sort strings components using Excel

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

Parsing and comparing a complicated string

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.

Resources