Split Function - divide cell by string

Question

I am trying to divide merged information from one cell into separate cells.

one cell:

amount:2 price:253,18 price2:59,24 EU status:WBB NAS MRR OWA PXA min:1 opt:3 category: PNE code z:195750

divided data: (I want to export each part into another cell)

amount:2	price:253,18	price2:59,24 EU	status:WBB NAS MRR OWA PXA	min:1	opt:3	category: PNE	code z:195750

I can't simply divide by finding empty space, status cell which is case-sensitive | status:WBB NAS MRR OWA PXA| has a different data range with spaces that can't be divided.

Split ( expression [,delimiter] [,limit] [,compare] )

    Sub Split_VBA()
'Create variables
Dim MyArray() As String, MyString As String, N As Integer, Temp As String

MyString = B2 ' TRYING TO GET DATA FROM CELL B2 TO SPLIT IT
'Use the split function to divide the string using a string "price:"
MyArray = Split(MyString, "price:")

    Dim arr() As String
    ' Split the string to an array
    arr = Split(B2, "price:") 'try to divide first part of data when appears string 'price:'

   For N = 0 To UBound(MyArray)
     'place each array element plus a line feed character into a string
    Temp = Temp & MyArray(N) & vbLf
Next N
'   I WOULD LIKE TO PROVIDE RESULT IN A ROW NOT IN A COLUMN
Range("A1") = Temp

End Sub

So far this VBA code seems to be a little above my abilities and as far as I checked some online available samples, tried to provide code as below, but I just got stuck and I hereby ask you dear community for some piece of advice.

Answer 1

As the order is the same one way is to simply search for adjacent key names & parse out whats in-between:

Sub g()

    Dim stringValue As String
    
    stringValue = "amount:2 price:253,18 price2:59,24 EU status:WBB NAS MRR OWA PXA min:1 opt:3 category: PNE code z:195750"
    
    Debug.Print getPart(stringValue, "amount", "price")
    Debug.Print getPart(stringValue, "price", "price2")
    Debug.Print getPart(stringValue, "price2", "status")
    Debug.Print getPart(stringValue, "status", "min")
    Debug.Print getPart(stringValue, "min", "opt")
    Debug.Print getPart(stringValue, "opt", "category")
    Debug.Print getPart(stringValue, "category", "code z")
    Debug.Print getPart(stringValue, "code z", "", True)

End Sub

Function getPart(value As String, fromKey As String, toKey As String, Optional isLast As Boolean = False) As String
    Dim pos1 As Long, pos2 As Long
    
    pos1 = InStr(1, value, fromKey & ":")
    
    If (isLast) Then
        pos2 = Len(value)
    Else
        pos2 = InStr(pos1, value, toKey & ":")
    End If
    
    getPart = Trim$(Mid$(value, pos1, pos2 - pos1))
End Function

---

amount:2
price:253,18
price2:59,24 EU
status:WBB NAS MRR OWA PXA
min:1
opt:3
category: PNE
code z:19575

Answer 2

Several choices:

• The pattern you show is that each split can be determined by a single word (no spaces) followed by a colon.
  • This can be easily replicated as a regular expression pattern, and implemented in VBA.
• However, if your splitword might have a space, then you'll need a different solution:

VBA Regex Solution

'Set Reference to Microsoft VBScript Regular Expressions 5.5
Option Explicit
Function splitIt(S)
    Dim RE As RegExp, MC As MatchCollection, M As Match
    Dim vResult As Variant, I As Long
    Const sPat As String = "\w+:.*?(?=(?:\w+:)|$)"
    
Set RE = New RegExp
With RE
    .Global = True
    .Pattern = sPat
    If .Test(S) = True Then
        Set MC = .Execute(S)
        ReDim vResult(1 To MC.Count)
        I = 0
        For Each M In MC
            I = I + 1
            vResult(I) = M
        Next M
    Else
        vResult = "split pattern not present"
    End If
End With

splitIt = vResult
End Function

This function outputs a horizontal array of values. In versions of Excel with dynamic arrays, this will Spill into the adjacent cells. In older versions, you may have to enter it as an array formula; use INDEX for each element; or rewrite this as a Sub to output to the specific cells

Split on word: regex explanation

\w+:.*?(?=(?:\w+:)|$)

• Match a single character that is a “word character” \w+
  • Between one and unlimited times, as many times as possible, giving back as needed (greedy) +
• Match the colon character :
• Match any single character that is NOT a line break character .*?
  • Between zero and unlimited times, as few times as possible, expanding as needed (lazy) *?
• Assert that the regex below can be matched starting at this position (positive lookahead) (?=(?:\w+:)|$)
  • Match this alternative (?:\w+:)
    • Match the regular expression below (?:\w+:)
      • Match a single character that is a “word character” \w+
        • Between one and unlimited times, as many times as possible, giving back as needed (greedy) +
      • Match the colon character :
  • Or match this alternative $
    • Assert position at the very end of the string $

Created with RegexBuddy

Answer 3

Split - Join - ReSplit

Instead of coding fixed categories, this late approach reads in any category from the base string before executing Split actions (only exception code z will be treated in an extra step):

• 1 define delimiters
• 2 tokenize base string (split action via blanks " ") and prefix a Pipe character "|" to the joined category elements
• 3 return results array via an eventual Pipe Split

Function getParts(ByVal s As String)
'Purpose: split into categories (identified by colon character ":")
'1. a) define delimiters
    Const Blank$ = " ", Colon$ = ":", Pipe$ = "|", Xtra$ = "^"
'   b) provide for category exception  "code z" (the only two words category)
    s = Replace(s, "code z", "code" & Xtra & "z")
    
'2. a) tokenize base string
    Dim tokens: tokens = Split(s, Blank)
'   b) prefix all ":" elements by Pipe char "|"
    Dim i As Long
    For i = 0 To UBound(tokens)              '
        tokens(i) = IIf(InStr(1, tokens(i), Colon), Pipe, Blank) & tokens(i)
    Next
'   c) restore mutilated "code z" category (back from "code^z")
    s = Replace(Join(tokens, vbNullString), Xtra, Blank)
    
'3. get results array via Pipe split
    getParts = Split(Mid$(s,2), Pipe)        ' edited due to FaneDurus comment
End Function

Answer 4

I'd look into some regular expression, for example:

[a-z\d ]+:[ ,A-Z\d]+

See an online demo

• [a-z\d ]+ - 1+ Lowercase alpha, space, or digit chars.
• : - A literal colon.
• [ ,A-Z\d]+ - 1+ Space, comma, uppercase alpha or digit.

---

VBA:

Sub Test()

Dim str As String: str = "amount:2 price:253,18 price2:59,24 EU status:WBB NAS MRR OWA PXA min:1 opt:3 category: PNE code z:195750"
Dim matches As Object

With CreateObject("vbscript.regexp")
    .Global = True
    .Pattern = "[a-z\d]+(?: [a-z\d]+)?:[ ,A-Z\d]+"
    If .Test(str) = True Then
        Set matches = .Execute(str)
        For Each match In matches
            Debug.Print Trim(match)
        Next
    End If
End With

End Sub

Answer 5

Another version of split/join/filter arrays:

Sub extractFromStr()
  Dim arrStr, arrFin, strInit As String, i As Long, k As Long
  Dim arr1, arr2, firstEl As String, secEl As String
  
  strInit = "amount:2 price:253,18 price2:59,24 EU status:WBB NAS MRR OWA PXA min:1 opt:3 category: PNE code z:195750"
  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 (first) array element 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...
        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
  'use here the first cell of the row where the processing result to be returned. Here, it returns on the first row:
  Range("A1").Resize(1, UBound(arrFin) + 1) = arrFin
End Sub