Macro similar to Text to Columns

[shre0047]

From a report, the data within one column will have multiple line breaks within the cell which I parsed out via marcro.

Here is an example the layout of the mentioned cell:

Full Text: Here is the full sentence Description: Here is the full description for support. Type (1): Color Type (1) Risk: High Type (2): Size Type (2) Risk: Low Type (3): Volume Type (3) Risk: High

<tbody>
</tbody>

I have the following macro set up and it works for the happy path

Sub splitText()


    Application.ScreenUpdating = False


    'splits Text active cell using ALT+10 char as separator
    Dim splitVals As Variant
    Dim totalVals As Long
    Dim i As Integer
    
    'Add columns to avoid overwriting data
    Columns("D:O").Select
    Selection.Insert Shift:=xlToRight
    Range("C2").Select
 
    For i = 1 To 1000
      splitVals = Split(ActiveCell.Value, Chr(10))
      totalVals = UBound(splitVals)
      Range(Cells(ActiveCell.Row, ActiveCell.Column + 1), Cells(ActiveCell.Row, ActiveCell.Column + 1 + totalVals)).Value = splitVals
      ActiveCell.Offset(1, 0).Activate
    Next i
    
    'Delete blank columns
    Columns("E").EntireColumn.Delete
    Columns("F").EntireColumn.Delete
    Columns("H").EntireColumn.Delete
    Columns("J").EntireColumn.Delete
    
    Columns("D:K").ColumnWidth = 20
    
    'Add Column Headers
    Range("D1").Select
    ActiveCell.FormulaR1C1 = "Full Text"
    Range("E1").Select
    ActiveCell.FormulaR1C1 = "Description"
    Range("F1").Select
    ActiveCell.FormulaR1C1 = "Type (1)"
    Range("G1").Select
    ActiveCell.FormulaR1C1 = "Type (1) Risk"
    Range("H1").Select
    ActiveCell.FormulaR1C1 = "Type (2)"
    Range("I1").Select
    ActiveCell.FormulaR1C1 = "Type (2) Risk"
    Range("J1").Select
    ActiveCell.FormulaR1C1 = "Type (3)"
    Range("K1").Select
    ActiveCell.FormulaR1C1 = "Type (3) Risk"
    
    'Remove unnecessary wording in each cell
    Columns("D").Replace What:="Full Text: ", Replacement:=""
    Columns("E").Replace What:="Description: ", Replacement:=""
    Columns("F").Replace What:="Type (1): ", Replacement:=""
    Columns("G").Replace What:="Type (1) Risk: ", Replacement:=""
    Columns("H").Replace What:="Type (2): ", Replacement:=""
    Columns("I").Replace What:="Type (2) Risk: ", Replacement:=""
    Columns("J").Replace What:="Type (1): ", Replacement:=""
    Columns("K").Replace What:="Type (1) Risk: ", Replacement:=""
    
    Application.ScreenUpdating = True
 
    End Sub

What I need help with are the two different scenarios:
1 - One row will have 3 types listed out, and the following row will have 2 types listed out. Is there a way to make an iteration to make it separate?

Full Text: Here is the full sentence Description: Here is the full description for support. Type (1): Color Type (1) Risk: High Type (2): Size Type (2) Risk: Low Type (3): Volume Type (3) Risk: High

Full Text: Here is the full sentence Description: Here is the full description for support. Type (1): Color Type (1) Risk: High Type (2): Size Type (2) Risk: Low

<tbody>
</tbody>

2 - If a cell has incorrect line breaks

Full Text: Here is the full sentence Description: Here is the full description for support. Type (1): Color Type (1) Risk: High Type (2): Size Type (2) Risk: Low Type (3): Volume Type (3) Risk: High

<tbody>
</tbody>

 

[Fluff]

You can use text to columns for the 1st part like

    Range("C:C").TextToColumns Destination:=Range("C1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="" & Chr(10) & "", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, _
        1), Array(6, 1), Array(7, 1), Array(8, 1)), TrailingMinusNumbers:=True

 

[shre0047]

For some reason, the excel report doesn't correctly utilize the "Text to Columns" feature or your macro. It deletes everything after the first link within each cell of column C. Attached is an excel file to reference.

In the examples listed above, when I ran the VBA/Text to Columns, it would just give the following:

Full Text: Here is the full sentence

<tbody>
</tbody>

All adjacent cells (D2, E2, F2, etc.) were are blank as well, as Text to Columns didn't work.

 

[Fluff]

Did you try my code on its own, or as part of your code?

 

[shre0047]

I attempted it as a separate macro

 

[Fluff]

That's odd, because both codes are looking for Chr(10).
Could you upload a test file to a share site such as DropBox or Onedrive & post a link to the thread?

 

[shre0047]

Prior to the macros, I attempted to utilize Text to Columns with Char(10) and didn't have any success. It appears the generated report has disabled it somehow?

The following link is an example of the different types of scenarios I want the macro to generate
https://1drv.ms/x/s!Ai0Yc6HP0e36a4-oZqi18rX0OB8

 

[Fluff]

You've got a whole mix of characters in there which is probably causing the probs.
I'll have a look tomorrow.

 

[Fluff]

Ok, try this

Sub suggestedmacro()
   With Range("C2", Range("C" & Rows.Count).End(xlUp))
      .Replace Chr(10), "|", xlPart, , , , False, False
      .Value = Evaluate("if({1},clean(" & .Address & "))")

      .TextToColumns Destination:=Range("C2"), DataType:=xlDelimited, _
         TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
         Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
         :="|", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, _
         1), Array(6, 1), Array(7, 1), Array(8, 1)), TrailingMinusNumbers:=True
   End With
End Sub

 

[shre0047]

It does work perfectly in the file. However, when I attempted in another file, it gets an error and provides "#VALUE" for all cells within column C.

https://1drv.ms/x/s!Ai0Yc6HP0e36cGCaRvaxmRJHkdw