String Parsing

[airforceone]

00000 TEMPLATE.xlsx
	A	B	C	D
1	Copied Entry	Expected Result
2	Dog*Brown,White,Black,Dragon*Golden,Green,Red,Black,Panda*Red,Black,Green	Dog*Brown,White,Black	Dragon*Golden,Green,Red,Black	Panda*Red,Black,Green
Sheet1 (2)

As shown above I would like to parse the cell value for every "*" entry to arrive at the expected result, below is my somewhat working code
Number of Pet may go up as many as 8 sets, in the above example we have 3 Pet Sets ie. Dog, Dragon and Panda.

Sub ListOfAnimals()
    Dim aPets() As String
    Dim iCTR As Long
    aPets = Split(Cells(2, 1), "*")
    For iCTR = LBound(aPets) To UBound(aPets)
        Debug.Print aPets(iCTR)
    Next
End Sub

 

[Peter_SSs]

Perhaps you could employ a user-defined function like this?

Function PetList(s As String, Num As Long) As String
  Dim RX As Object, M As Object
  
  Set RX = CreateObject("VBScript.RegExp")
  RX.Global = True
  RX.Pattern = "([^,]+\*.+?)(\,?)(?=([^,]+\*)|$)"
  Set M = RX.Execute(s)
  If Num <= M.Count Then PetList = M(Num - 1).SubMatches(0)
End Function

airforceone_1.xlsm
	A	B	C	D	E
1	Copied Entry	Expected Result
2	Dog*Brown,White,Black,Dragon*Golden,Green,Red,Black,Panda*Red,Black,Green	Dog*Brown,White,Black	Dragon*Golden,Green,Red,Black	Panda*Red,Black,Green
Sheet1

Cell Formulas
Range	Formula
B2:E2	B2	=PetList($A2,COLUMNS($B:B))

 

[Marc L]

According to Logic & VBA basics text functions the classic Filter / Split way :​

Sub Demo1()
  Const D = ","
    Dim S$(), R&
        S = Split([A2].Text, D)
        R = UBound(S)
    While R
        If Not S(R) Like "*[*]*" Then S(R - 1) = S(R - 1) & D & S(R): S(R) = False
        R = R - 1
    Wend
        S = Filter(S, False, False)
        If UBound(S) > -1 Then [B2].Resize(, UBound(S) + 1).Value2 = S
End Sub

 

[airforceone]

Perhaps you could employ a user-defined function like this?

Function PetList(s As String, Num As Long) As String
  Dim RX As Object, M As Object
 
  Set RX = CreateObject("VBScript.RegExp")
  RX.Global = True
  RX.Pattern = "([^,]+\*.+?)(\,?)(?=([^,]+\*)|$)"
  Set M = RX.Execute(s)
  If Num <= M.Count Then PetList = M(Num - 1).SubMatches(0)
End Function

airforceone_1.xlsm
	A	B	C	D	E
1	Copied Entry	Expected Result
2	Dog*Brown,White,Black,Dragon*Golden,Green,Red,Black,Panda*Red,Black,Green	Dog*Brown,White,Black	Dragon*Golden,Green,Red,Black	Panda*Red,Black,Green
Sheet1

Cell Formulas
Range	Formula
B2:E2	B2	=PetList($A2,COLUMNS($B:B))

I can't get seems to run the code?

 

[Peter_SSs]

Perhaps the code went in the wrong place. To implement ..
1. Right click the sheet name tab and choose "View Code".
2. In the Visual Basic window use the menu to Insert|Module
3. Copy and Paste the code below (you can use the icon at the top right of the code pane below) into the main right hand pane that opens at step 2.
4. Close the Visual Basic window.
5. Enter the formula as shown in the screen shot .... and copy across (& down if multiple rows).
6. Your workbook will need to be saved as a macro-enabled workbook (*.xlsm)

 

[airforceone]

According to Logic & VBA basics text functions the classic Filter / Split way :​

Sub Demo1()
  Const D = ","
    Dim S$(), R&
        S = Split([A2].Text, D)
        R = UBound(S)
    While R
        If Not S(R) Like "*[*]*" Then S(R - 1) = S(R - 1) & D & S(R): S(R) = False
        R = R - 1
    Wend
        S = Filter(S, False, False)
        If UBound(S) > -1 Then [B2].Resize(, UBound(S) + 1).Value2 = S
End Sub

not available for Office 2016 - 2019?

 

[airforceone]

Perhaps the code went in the wrong place. To implement ..
1. Right click the sheet name tab and choose "View Code".
2. In the Visual Basic window use the menu to Insert|Module
3. Copy and Paste the code below (you can use the icon at the top right of the code pane below) into the main right hand pane that opens at step 2.
4. Close the Visual Basic window.
5. Enter the formula as shown in the screen shot below and copy across (& down if multiple rows).
6. Your workbook will need to be saved as a macro-enabled workbook (*.xlsm)

Already saved it to macro-enabled workbook (*.xlsm)
I hope I implemented it right?

 

[Peter_SSs]

From those images I cannot see where you pasted the code & I cannot see the actual formula in the column B cells, only what you have typed into column C

In the vba window, double-click on the module where you pasted the code then snip an image that shows the module selected (pale grey) & the code on the right

Can you also post the range A1:B2 of your sheet with XL2BB
so we can copy/check your actual data and formula?

 

[airforceone]

From those images I cannot see where you pasted the code & I cannot see the actual formula in the column B cells, only what you have typed into column C

In the vba window, double-click on the module where you pasted the code then snip an image that shows the module selected (pale grey) & the code on the right

View attachment 60271


Can you also post the range A1:B2 of your sheet with XL2BB
so we can copy/check your actual data and formula?

00000 TEMPLATE.xlsm
	A	B
1	Entry	Formula
2	Dog*Brown,White,Black,Dragon*Golden,Green,Red,Black,Eagle*Red,Black,Green	#NAME?
StringParsing (2)

Cell Formulas
Range	Formula
B2	B2	=PetList($A2,COLUMNS($B:B))

 

[Peter_SSs]

You have placed the code in a different location to that suggested. Try it, as indicated, in a module in the workbook where it will be used, not in your personal macro workbook.