Excel VBA - Separate data by pattern by using Split Function - excel

Question

I am working on a special filter to divide cell from column E24:E33 into separate cells in range F24:M33
There are pattern words by which I want to divide the data:
amount: price: price2: status: min: opt: cat: code z:
I have already tested several methods to solve this issue, but none gave me a proper results. Unfortunately I am not a VBA programmer on such a high level to write it on my own completely from scratch.
This is the code I have so far but still the data is not being correctly divided:
Sub qtest()
Dim a As Variant, b As Variant
'a = SpecialSplit("asdf:asdf asds:ert ert qwe d:sdfg") 'THIS TEST DATA WORKS FINE
a = SpecialSplit("amount:3 pc. price:2397 price2:0 EU status:In use min:1 opt:3 cat: DESTACO code z:") DOESN'T WORK FOR ONE CELL
'SpecialSplit = Sheets("T4").Range("E24" & Rows.Count).End(xlUp).Row 'ALSO DOESN't WORK FOR ENTIRE RANGE
ActiveCell.Offset(0, 1).Resize(1, UBound(a) - LBound(a) + 1).value = a
End Sub
Function SpecialSplit(Compound As String) As Variant
Dim pos1 As Long, pos2 As Long
Dim firstSplit As Variant
Dim elmts As Integer
Dim elmt As Integer
Dim oneel As String
firstSplit = Split(Compound, ":")
For elmt = LBound(firstSplit) To UBound(firstSplit) - 1
oneel = firstSplit(elmt + 1)
pos1 = InStr(oneel, " ")
pos2 = Len(oneel)
While pos1 > 0 And pos1 < Len(oneel) - 1
pos2 = pos1
pos1 = InStr(pos2 + 1, oneel, " ")
Wend
firstSplit(elmt) = firstSplit(elmt) & ":" & Left(oneel, pos2 - 1)
firstSplit(elmt + 1) = Right(oneel, Len(oneel) - pos2)
Next elmt
elmts = UBound(firstSplit) - LBound(firstSplit) ' one shorter
If elmts > 0 Then ReDim Preserve firstSplit(1 To elmts)
SpecialSplit = firstSplit
End Function
Sub SpecialSpread(FromCell As Range)
Dim splitSet As Variant
splitSet = SpecialSplit(FromCell(1).Text)
If UBound(splitSet) >= 0 Then
FromCell(1).Offset(0, 1).Resize(1, UBound(splitSet) - LBound(splitSet) + 1).value = splitSet
End If
End Sub
Sub qtest()
Dim a As Variant, b As Variant
'a = SpecialSplit("asdf:asdf asds:ert ert qwe d:sdfg") 'BY THIS PATTERN CODE WORKS
a = SpecialSplit("amount:3 pc. price:2397 price2:0 EU status:In use min:1 opt:3 cat: DESTACO code z:") ' BY THIS PATTERN CODE DOESN'T WORK
'SpecialSplit = Sheets("T4").Range("E2" & Rows.Count).End(xlUp).Row
ActiveCell.Offset(0, 1).Resize(1, UBound(a) - LBound(a) + 1).value = a
End Sub

Answer 1

You can do this in Power Query (available in Windows Excel 2010+ and Office 365.
This relies on the pattern words always being present and always in the same order.
In PQ we can actually split on the pattern words, so that part is easy.
If you just wanted to have the pattern words as column headers, we could stop there.
But since you want to have the pattern words precede the value in each cell, we have to Unpivot the table; create a merged column of the pattern word + : + value, then re-pivot on the Attribute column
To use it:
Select some cell in your Data Table
Data => Get&Transform => from Table/Range
When the PQ Editor opens: Home => Advanced Editor
Make note of the Table Name in Line 2
Paste the M Code below in place of what you see
Change the Table name in line 2 back to what was generated originally.
Read the comments and explore the Applied Steps to understand the algorithm
M Code
let
Source = Excel.CurrentWorkbook(){[Name="Table7"]}[Content],
#"Changed Type" = Table.TransformColumnTypes(Source,{{"Column1", type text}}),
//List to split on
codeList = {
"amount:",
"price:",
"price2:",
"status:",
"min:",
"opt:",
"category:",
"code z:"},
//strip off terminal colon (:) to create list of column headers
colNames = List.Transform(codeList, each Text.TrimEnd(_,":")),
//split on the code list, and name the new columns
split = Table.SplitColumn(#"Changed Type","Column1",
Splitter.SplitTextByEachDelimiter(codeList),List.Combine({{"Column1"},colNames})),
//remove the now empty column1
#"Removed Columns" = Table.RemoveColumns(split,{"Column1"}),
//could stop here if didn't have to merge the column header with the value
//To prefix each measurement with pattern word
#"Unpivoted Columns" = Table.UnpivotOtherColumns(#"Removed Columns", {}, "Attribute", "Value"),
#"Duplicated Column" = Table.DuplicateColumn(#"Unpivoted Columns", "Attribute", "Attribute - Copy"),
#"Merged Columns" = Table.CombineColumns(#"Duplicated Column",
{"Attribute", "Value"},Combiner.CombineTextByDelimiter(":", QuoteStyle.None),"Merged"),
rePivot = fnPivotAll(#"Merged Columns","Attribute - Copy","Merged")
in
rePivot
custom function
enter as blank query
rename fnPivotAll
//credit: Cam Wallace https://www.dingbatdata.com/2018/03/08/non-aggregate-pivot-with-multiple-rows-in-powerquery/
(Source as table,
ColToPivot as text,
ColForValues as text)=>
let
PivotColNames = List.Buffer(List.Distinct(Table.Column(Source,ColToPivot))),
#"Pivoted Column" = Table.Pivot(Source, PivotColNames, ColToPivot, ColForValues, each _),
TableFromRecordOfLists = (rec as record, fieldnames as list) =>
let
PartialRecord = Record.SelectFields(rec,fieldnames),
RecordToList = Record.ToList(PartialRecord),
Table = Table.FromColumns(RecordToList,fieldnames)
in
Table,
#"Added Custom" = Table.AddColumn(#"Pivoted Column", "Values", each TableFromRecordOfLists(_,PivotColNames)),
#"Removed Other Columns" = Table.RemoveColumns(#"Added Custom",PivotColNames),
#"Expanded Values" = Table.ExpandTableColumn(#"Removed Other Columns", "Values", PivotColNames)
in
#"Expanded Values"
Raw Data
Split Data
Alternative solution

Answer 2

Try the next function, please:
Function extractFrStr(strInit As String) As Variant
Dim arrStr, arrFin, i As Long, k As Long
Dim arr1, arr2, firstEl As String, secEl As String
arrStr = Split(strInit, ":") 'split the string by ":" character
ReDim arrFin(UBound(arrStr)) 'ReDim the final array at the same number of elements
For i = 0 To UBound(arrStr) - 1 'iterate between the array elements (except the last)
arr1 = Split(arrStr(i), " ") 'split the i element by space (" ")
arr2 = Split(arrStr(i + 1), " ") 'split the i + 1 element by space (" ")
If i = 0 Then 'for the first array element:
firstEl = arrStr(i) 'it receives the array elemen value
Else 'for the rest of array elements:
'extract firstEl (category) like first arr1 element, except the case of 'code z' which is extracted in a different way
firstEl = IIf(i = UBound(arrStr) - 1, arr1(UBound(arr1) - 1) & " " & arr1(UBound(arr1)), arr1(UBound(arr1)))
End If
'in order to remove array elements, the code transformes the one to be removed in "|||":
'it could be anything, but "|||" is difficult to suppose that it will be the text of a real element...
If arrStr(i + 1) <> "" Then arr2(UBound(arr2)) = "|||": If i = UBound(arrStr) - 2 Then arr2(UBound(arr2) - 1) = "|||"
'extract the secEl (the value) by joining the array after removed firstEl:
secEl = IIf(i = UBound(arrStr) - 1, arrStr(UBound(arrStr)), Join(Filter(arr2, "|||", False), " "))
arrFin(k) = firstEl & ":" & secEl: k = k + 1 'create the processed element of the array to keep the result
Next i
extractFrStr = arrFin
End Function
And use it to process your range, in the next way:
Sub SplitCategories()
Dim sh As Worksheet, c As Range, arr
Set sh = ActiveSheet
For Each c In sh.Range("E24:E33").cells
arr = extractFrStr(Trim(c.value))
c.Offset(0, 1).Resize(1, UBound(arr)).value = arr
Next c
End Sub

Answer 3

Well OK, that's mostly the code I gave you in a previous question/answer. In order to implement a split of cells in E24:E33, you just need to feed those cells to the SpecialSpread routine... all the qtest stuff is just testing routines.
So this adds a SpreadZone routine to act on that specific range:
Function SpecialSplit(Compound As String) As Variant
Dim pos1 As Long, pos2 As Long
Dim firstSplit As Variant
Dim elmts As Integer
Dim elmt As Integer
Dim oneel As String
firstSplit = Split(Compound, ":")
For elmt = LBound(firstSplit) To UBound(firstSplit) - 1
oneel = firstSplit(elmt + 1)
pos1 = InStr(oneel, " ")
pos2 = Len(oneel)
While pos1 > 0 And pos1 < Len(oneel) - 1
pos2 = pos1
pos1 = InStr(pos2 + 1, oneel, " ")
Wend
firstSplit(elmt) = firstSplit(elmt) & ":" & Left(oneel, pos2 - 1)
firstSplit(elmt + 1) = Right(oneel, Len(oneel) - pos2)
Next elmt
elmts = UBound(firstSplit) - LBound(firstSplit) ' one shorter
If elmts > 0 Then
oneel = firstSplit(UBound(firstSplit))
ReDim Preserve firstSplit(1 To elmts)
firstSplit(elmts) = firstSplit(elmts) & ":" & oneel
End If
SpecialSplit = firstSplit
End Function
Sub SpecialSpread(FromCell As Range)
Dim splitSet As Variant
splitSet = SpecialSplit(FromCell(1).Text)
If UBound(splitSet) >= 0 Then
FromCell(1).Offset(0, 1).Resize(1, UBound(splitSet) - LBound(splitSet) + 1).value = splitSet
End If
End Sub
Sub SpreadZone()
Dim ACell As Range
For Each ACell In Range("E24:E33")
Call SpecialSpread(ACell)
Next ACell
End Sub
Edit: tweaked SpecialSplit a little to improve last field & correct empty field handling