Macro similar to Text to Columns

S

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]
 
Sort by date Sort by votes
Ok, how about
Code: 
Sub suggestedmacro()
   With Range("C2", Range("C" & Rows.Count).End(xlUp))
      .Replace Chr(10), "|", xlPart, , , , False, False
      .Replace Chr(13), "", xlPart, , , , False, False

      .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

Excel Facts

Convert text numbers to real numbers
Select a column containing text numbers. Press Alt+D E F to quickly convert text to numbers. Faster than "Convert to Number"
Thank you for your help as it works as I wanted!

Code: 
Sub splitText()

    Application.ScreenUpdating = False
    
    'Add columns to avoid overwriting data
    Columns("D:J").Select
    Selection.Insert Shift:=xlToRight
    Range("C2").Select
    
    'Run TexttoColumn
    With Range("C2", Range("C" & Rows.Count).End(xlUp))
      .Replace Chr(10), "|", xlPart, , , , False, False
      .Replace Chr(13), "", xlPart, , , , False, False


      .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
 
    'Delete Req Full Text column
    Columns("C").EntireColumn.Delete
    
    Columns("C:I").ColumnWidth = 20
    
    'Add Column Headers
       Dim rng As Range
    Dim i As Long


    'Set the range in column A you want to loop through
    Set rng = Range("C2:I2")
    For Each cell In rng
         If Left(cell.Value, 23) = "Requirement Description" Then
            'write to adjacent cell
            cell.Offset(-1, 0).Value = "Req Description"
        End If


        If Left(cell.Value, 19) = "Compliance Area (1)" Then
            'write to adjacent cell
            cell.Offset(-1, 0).Value = "Compliance Area (1)"
        End If
        
        If Left(cell.Value, 24) = "Compliance Area (1) Risk" Then
            'write to adjacent cell
            cell.Offset(-1, 0).Value = "Compliance Area (1) Risk"
        End If
        
        If Left(cell.Value, 19) = "Compliance Area (2)" Then
            'write to adjacent cell
            cell.Offset(-1, 0).Value = "Compliance Area (2)"
        End If
        
        If Left(cell.Value, 24) = "Compliance Area (2) Risk" Then
            'write to adjacent cell
            cell.Offset(-1, 0).Value = "Compliance Area (2) Risk"
        End If
        
        If Left(cell.Value, 19) = "Compliance Area (3)" Then
            'write to adjacent cell
            cell.Offset(-1, 0).Value = "Compliance Area (3)"
        End If
        
        If Left(cell.Value, 24) = "Compliance Area (3) Risk" Then
            'write to adjacent cell
            cell.Offset(-1, 0).Value = "Compliance Area (3) Risk"
        End If
    Next
    
    
    Application.ScreenUpdating = True
 
    End Sub

I also added the macro to find the phrases within the first entry (row2) of the file and provide the header. Is there a way to do something along the lines of (pseudocode):
If Left(cell.Value, 23) = "Requirement Description"
Then Replace What:="Requirement Description: ", Replacement:="" (Replace for the entire column)
cell.Offset(-1, 0).Value = "Req Description"
End If
 
Last edited:
Upvote 0
How about
Code: 
Sub splitText()
   Dim Ary As Variant
   Dim i As Long
   Dim Fnd As Range
   Dim j As Long
   Application.ScreenUpdating = False
   
   'Add columns to avoid overwriting data
   Columns("D:J").Insert Shift:=xlToRight
   
   'Run TexttoColumn
   With Range("C2", Range("C" & Rows.Count).End(xlUp))
      .Replace Chr(10), "|", xlPart, , , , False, False
      .Replace Chr(13), "", xlPart, , , , False, False
   
      .TextToColumns Range("C2"), xlDelimited, xlDoubleQuote, True, False, False, False, False, True, "|"
   End With

   'Delete Req Full Text column
   Columns("C").EntireColumn.Delete
   
   Columns("C:I").ColumnWidth = 20
    
   'Add Column Headers
   Ary = Array("Requirement Description", "Compliance Area (1) Risk", "Compliance Area (1)", "Compliance Area (2) Risk", "Compliance Area (2)", "Compliance Area (3) Risk""Compliance Area (3)")
   For i = 0 To UBound(Ary)
      Set Fnd = Range("B2")
      For j = 1 To Application.CountIf(Range("C2:J2"), Ary(i) & "*")
         Set Fnd = Range("B2:J2").Find(Ary(i), Fnd, , xlPart, , , False, , False)
         If Not Fnd Is Nothing Then
            Fnd.EntireColumn.Replace Ary(i) & ": ", "", xlPart, , False, , False, False
            Fnd.Offset(-1).Value = Ary(i)
         End If
      Next j
   Next i
End Sub
 
Upvote 0
For some reason, the text for a few cells are appearing as the following:
[TABLE="class: outer_border, width: 500"]
<tbody>[TR]
[TD]Requirement Description: The following requirement is related to the ability of the application to archive data using the standard relational database archiving process. Data should be able to be archived into Optim without error or
issue.


Compliance Area (1):[/TD]
[/TR]
</tbody>[/TABLE]

Am i able to follow the same code you listed to eliminate the line break within the 'Requirement Description' section?
 
Upvote 0
About the only I can think of is to do something like
Code: 
   With Range("C2", Range("C" & Rows.Count).End(xlUp))
      .Replace Chr(13), "", xlPart, , , , False, False
      .Replace Chr(10), "|", xlPart, , , , False, False
      [COLOR=#0000ff].Replace "|issue", "issue", xlPart, , , , False, False
      .Replace "|the", "the", xlPart, , , , False, False[/COLOR]
      .TextToColumns Range("C2"), xlDelimited, xlDoubleQuote, True, False, False, False, False, True, "|"
   End With
and create other similar lines for all oddities.
 
Upvote 0
Another option is
Code: 
   With Range("C2", Range("C" & Rows.Count).End(xlUp))
      .Replace Chr(13), "", xlPart, , , , False, False
      .Replace Chr(10), "|", xlPart, , , , False, False
      .Replace "|Req", Chr(10) & "Req", xlPart, , , , False, False
      .Replace "|Comp", Chr(10) & "Comp", xlPart, , , , False, False
      .Replace "|", "", xlPart, , , , False, False
      .TextToColumns Range("C2"), xlDelimited, xlDoubleQuote, True, False, False, False, False, True, Chr(10)
   End With
which should hopefully deal with all oddities.
 
Upvote 0
I believe this did everything I am looking for. Thank you so much for your help!
 
Upvote 0
Glad to help & thanks for the feedback
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Question Question
Operational Risk Methodology on VBA
Replies
0
Views
122
Mazurofgod
M
K
  • Question Question
Rolled up color coding
Replies
3
Views
257
felixstraube
F
R
  • Question Question
[VBA] - Need to Hide one column and need sum of columns
Replies
0
Views
197
rsolanki
R
K
  • Solved
Conditionally sum fractional cells based on column headings
Replies
5
Views
161
Cubist
Cubist
J
  • Question Question
Macro to pull Office 365 'Comments' onto new tab like I previously did with what's now 'Notes'
Replies
1
Views
144
jkouvel
J

Forum statistics

Threads
1,224,823
Messages
6,181,176
Members
453,021
Latest member
Justyna P

Share this page

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