Macro similar to Text to Columns

shre0047

Board Regular
Joined
Feb 3, 2017
Messages
53
Office Version
  1. 365
Platform
  1. Windows
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:
[TABLE="class: outer_border, width: 500"]
<tbody>[TR]
[TD]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
[/TD]
[/TR]
</tbody>[/TABLE]

I have the following macro set up and it works for the happy path
Code:
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?
[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]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
[/TD]
[/TR]
[TR]
[TD]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

[/TD]
[/TR]
</tbody>[/TABLE]


2 - If a cell has incorrect line breaks
[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]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
[/TD]
[/TR]
</tbody>[/TABLE]
 

Excel Facts

Copy PDF to Excel
Select data in PDF. Paste to Microsoft Word. Copy from Word and paste to Excel.
You can use text to columns for the 1st part like
Code:
    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
 
Upvote 0
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:
[TABLE="class: outer_border, width: 500"]
<tbody>[TR]
[TD]Full Text: Here is the full sentence
[/TD]
[/TR]
</tbody>[/TABLE]

All adjacent cells (D2, E2, F2, etc.) were are blank as well, as Text to Columns didn't work.
 
Upvote 0
Did you try my code on its own, or as part of your code?
 
Upvote 0
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?
 
Upvote 0
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
 
Upvote 0
You've got a whole mix of characters in there which is probably causing the probs.
I'll have a look tomorrow.
 
Upvote 0
Ok, try this
Code:
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
 
Upvote 0

Forum statistics

Threads
1,223,888
Messages
6,175,219
Members
452,620
Latest member
dsubash

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top