RegEx Row Column Listing Error

[airforceone]

coming from this thread String Parsing

I was able to convert @Peter_SSs function code to an ordinary procedure. (thanks again @Peter_SSs )

Sub PetListII()
 
  Dim RX As Object, M As Object, RXCtr As Integer
    
    Dim K As Integer, ConfisKated As String, FullName As Variant, MaxNumero() As Integer

    Set WSCopy = ActiveSheet
    ActiveSheet.Select
        
    'Find the last non-blank cell in row 1
    LastRow = Cells(rows.Count, 1).End(xlUp).Row
    'Find the last non-blank cell in COL 1
    LastCol = Cells(1, Columns.Count).End(xlToLeft).Column
        
    ReDim MaxNumero(LastRow)
'------------------------------
'
'   Count The "," in a string
'   Result will be used for the looping sequence
'
'------------------------------
    For K = 2 To LastRow
        MaxNumero(K) = Len(WSCopy.Range("A" & K)) - Len(Application.WorksheetFunction.Substitute(WSCopy.Range("A" & K), ",", "")) + 1
    Next K
    LastMaxNum = WorksheetFunction.Max(MaxNumero)
 
'------------------------------
'
'   RegEx Pattern
'   by  Peter_SSs
'   @ https://www.mrexcel.com/
'
'------------------------------
    Set RX = CreateObject("VBScript.RegExp")
    RX.Global = True
    RX.Pattern = "([^,]+\*.+?)(\,?)(?=([^,]+\*)|$)"
    
    Set M = RX.Execute(Cells(2, 1))
    RXCtr = 0
    For K = 2 To LastRow
        For iCTR = 2 To LastMaxNum
            Cells(K, iCTR).Value = M(RXCtr).SubMatches(0)
            RXCtr = RXCtr + 1
        Next
    Next
    
End Sub

But got hit by another roadblock. what I'm trying to achieved here is to process all rows and output in their respective cell address.
I think the code

Set M = RX.Execute(Cells(2, 1))

outside of the loop is causing the "Run-time error '5'; Invalid Procedure call or argument" in

Cells(K, iCTR).Value = M(RXCtr).SubMatches(0)

X TEMPLATE.xlsm
	A	B	C	D
1	Entry	RESULT
2	Dog*Brown,White,Black,Dragon*Golden,Green,Red,Black,Eagle*Red,Black,Green	Dog*Brown,White,Black	Dragon*Golden,Green,Red,Black	Eagle*Red,Black,Green
3	Dog*Brown,White,Black,Eagle*Red,Black,Green	Dog*Brown,White,Black	Eagle*Red,Black,Green
4	Dragon*Golden,Green,Red,Black	Dragon*Golden,Green,Red,Black
5	Dog*Brown,White,Black,Dragon*Golden,Green,Red,Black,Eagle*Red,Black,Green	Dog*Brown,White,Black	Dragon*Golden,Green,Red,Black	Eagle*Red,Black,Green
6	Dog*Brown,White,Black,Dragon*Golden,Green,Red,Black,Eagle*Red,Black,Green	Dog*Brown,White,Black	Dragon*Golden,Green,Red,Black	Eagle*Red,Black,Green
StringParsing (3)

 

[Peter_SSs]

Try this

Sub Pet_Lists()
  Dim RX As Object
  Dim a As Variant
  Dim i As Long
  
  Set RX = CreateObject("VBScript.RegExp")
  RX.Global = True
  RX.Pattern = "(\,)(?=([^,]+\*)|$)"
  With Range("A2", Range("A" & Rows.Count).End(xlUp))
    a = .Value
    For i = 1 To UBound(a)
      a(i, 1) = RX.Replace(a(i, 1), ";")
    Next i
    With .Offset(, 1)
      .Value = a
      .TextToColumns DataType:=xlDelimited, Semicolon:=True, Comma:=False, Space:=False, Other:=False
    End With
  End With
End Sub

 

[airforceone]

Try this

Sub Pet_Lists()
  Dim RX As Object
  Dim a As Variant
  Dim i As Long
 
  Set RX = CreateObject("VBScript.RegExp")
  RX.Global = True
  RX.Pattern = "(\,)(?=([^,]+\*)|$)"
  With Range("A2", Range("A" & Rows.Count).End(xlUp))
    a = .Value
    For i = 1 To UBound(a)
      a(i, 1) = RX.Replace(a(i, 1), ";")
    Next i
    With .Offset(, 1)
      .Value = a
      .TextToColumns DataType:=xlDelimited, Semicolon:=True, Comma:=False, Space:=False, Other:=False
    End With
  End With
End Sub

It's working the way It was needed but after running the code this message keeps popping up..

 

[Peter_SSs]

The code is looking for any data in column A and expecting columns B,C, D, ... etc to be blank, ready to receive the results.
Do you already have something in columns B,C, D, ... etc?

 

[airforceone]

Thanks again @Peter_SSs what I did is issue a DisplayAlerts to suppress warning alert...

 

[airforceone]

The code is looking for any data in column A and expecting columns B,C, D, ... etc to be blank, ready to receive the results.
Do you already have something in columns B,C, D, ... etc?

I started it without contents... but still it keeps on popping...
columns B onward is empty..

 

[Peter_SSs]

I started it without contents... but still it keeps on popping...
columns B onward is empty..

If they are actually empty the alert will not pop up. There must be something somewhere in the road of the results.

If still problems, try adding this line where shown.

With .Offset(, 1)
  .Resize(, 50).ClearContents
  .Value = a
  .TextToColumns DataType:=xlDelimited, Semicolon:=True, Comma:=False, Space:=False, Other:=False
End With

 

[airforceone]

If they are actually empty the alert will not pop up. There must be something somewhere in the road of the results.

If still problems, try adding this line where shown.

With .Offset(, 1)
  .Resize(, 50).ClearContents
  .Value = a
  .TextToColumns DataType:=xlDelimited, Semicolon:=True, Comma:=False, Space:=False, Other:=False
End With

I don't know why but even with that "clearcontents" it's still popping
even if I manually clear the cell values to no avail...

 

[Peter_SSs]

even if I manually clear the cell values to no avail...

What cell values did you clear?

 

[airforceone]

What cell values did you clear?

column B onwards prior to running the code! but still not empty warning keeps popping up...
what I did is issued display alert to off/false, for now it's working until we figure out where is that warning coming from....
again Big Tango! (Big Thanks)